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NRL  CONNECTION  MACHINE  FORTRAN  LIBRARY 


I.  INTRODUCTION 

The  Naval  Research  Lab  (NRL)  Fortran  library  on  the  Connection  Machine  (CM)  [1]  consists 
of  numerous  mathematical  routines  coded  in  CM  Fortran  [2],  release  0.7,  along  with  lower  level 
routines  written  in  Paris  [3]  which  Jpulate  data,  plot  data,  and  perform  operations  unavailable 
in  the  context  of  the  CM  Fortran  language.  The  contributing  authors  to  this  library  package  were 
Eric  Hoffman,  Michael  Mascagni,  Charles  Del  Vecchio,  Robert  Whaley,  and  Michael  Young.  CM 
Fortran  consists  of  a  mixture  of  serial  and  parallel  array  operations.  Serial  operations  are  executed 
by  the  front-end  computer  using  its  own  memory  and  CPU.  The  parallel  operations  are  executed 
on  the  CM-2  where  each  processor  concurrently  executes  its  own  data  point.  Multidimensional 
arrays  are  allocated  on  the  CM-2,  one  element  per  processor.  Major  array  features  that  have  been 
adapted  from  draft  S8  of  the  ANSI  Fortran  8x  standard  (x3.9— 198x)  [4]  include  array  assignment, 
array  constructors,  and  array  sections.  The  where  statement  and  block  where  construct  are  also 
featured.  These  allow  the  user  to  operate  conditionally  on  array  elements  depending  on  their 
values. 

The  library  routines  fall  into  one  of  three  categories:  Paris  Support  Routines,  Graphics  Rou¬ 
tines,  or  Linear  Algebra  Routines.  The  Paris  Support  Routines  allow  the  user  to  perform  operations 
on  data  that  are  currently  not  expressable  in  the  context  of  the  CM  Fortran  language.  The  Graph¬ 
ics  Routines  aid  the  user  in  displaying  images  on  the  framebuffer,  a  high  speed  graphics  device. 
Lastly,  the  Linear  Algebra  Routines  consist  of  frequently  used  mathematical  operations.  The  pur¬ 
pose  of  each  library  routine  is  presented  along  with  the  parameters  required,  and  an  example  call 
to  the  particular  routine. 

Users  are  able  to  remain  entirely  within  the  CM  Fortran  programming  environment  while 
making  calls  to  these  library  routines.  Interfaces  to  the  Framebuffer,  a  high  resolution  graphics 
device  [5],  and  the  DataVault  [6],  a  high  speed  I/O  channel,  are  available.  A  user  may  access  these 
routines  from  a  CM  Fortran  program,  by  linking  with  the  library,  as  shown  in  Figure  1. 


cmf  my_program.fcm  -Inrlcmf 


Fig.  1  —  Linking  with  the  Library 

Some  routines  will  be  supplanted  by  the  introduction  of  the  CM  Scientific  Subroutine  Library 
(CMSSL)  [7].  The  CMSSL  software  package  is  supplied  directly  by  the  manufacturer  of  the  CM, 
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Thinking  Machines  Corporation(TMC). 


2.  Paris  Support  Routines 

The  Paris  support  routines  use  the  paris/fortran  interface  [2]  for  many  operations  that  are  not 
expressable  in  CM  Fortran.  These  operations  include  general  communication  between  processors, 
and  scanning  functions,  which  combine  calculation  and  communication. 


2.1  DataVault 

This  package  of  routines  is  used  to  read  and  writa  information  trom  the  CM  to  the  DataVault 
mass  storage  system.  The  DataVault  provides  a  file  system  and  permanent  disk  storage  for  the 
CM  data.  The  routines  provided  are  listed  in  Figure  2  with  appropriate  syntax.  These  routines 
work  with  arrays  of  type  integer,  logical,  real  and  double  precision.  Arrays  written  to  a  file  must 
conform,  i.e.  have  the  same  shape  [2]. 


dv_open(fd,path) 

dv_close(fd) 

dv_read(fd,buff) 

dv_write(fd,buff) 

dv_rewind(fd) 

dv  Jseek(fd , offset ) 

fd, offset  :  integer 

path  :  character  string 

buff  :  integer,  logical,  or  real  array 


Fig.  2  —  DataVault  Routines  Syntax 

Figure  3  demonstrates  an  example  call  to  dv_open,  which  creates  a  file  with  an  associated 
integer  unit  number  “fd”,  and  dv.close,  which  closes  a  file.  Shown  in  Figure  4  are  examples  of 
reading  and  writing  arrays  to  a  DataVault  file  using  dv_read  and  dv.write. 


dv_open(fd,path) 

dv_close(fd) 

integer  fd 

integer  fd 

fd  =  99 

call  dv_close(fd) 

call  dv_open(unit,’file_name’) 

Fig.  3  —  DataVault  Open/Close  Example 


Figure  5  illustrates  how  to  manipulate  the  file  pointer  using  subroutines  dv_rewind  and 
dvJseek.  Subroutine  dv.lseek  must  be  used  with  caution,  since  it  moves  the  file  pointer  “off- 


d  v_read  (  fd  ,b  uff ) 

dv_write(fd,buff) 

integer  fd 

integer  fd 

integer  buffl(128,  128) 

real  buff2(32,  32,  32) 

fd  =  99 

fd  =  99 

call  dv_read(fd,  buffi) 

call  dv_write(fd,  buffi2) 

Fig.  4  —  DataVault  Read/Write  Example 

set”  number  of  bits  from  its  current  position.  This  process  allows  the  user  to  “lseek”  to  values  of 
type  logical  within  a  file,  since  such  values  are  stored  as  bits  in  CM  Fortran. 


dvjrewind(fd) 

■ 

dvJseek(fd, offset) 

integer  fd 

■ 

integer  fd, offset 

call  dv_rewind(fd) 

1 

ofTset  =  10  *  32 

call  dvJseek(fd, offset) 

Fig.  5  —  DataVault  Reuiind/Lseek  Example 

Table  1  lists  the  read/write  rates  for  variable  length  blocks  measured  on  an  8K  CM-2  with  a 
10  Gigabyte  DataVault  at  NRL  [8]. 


Block  Size 

Read  Rate 

Write  Rate 

256K 

1.3 

0.6 

512K 

2.5 

1.3 

1024K 

5.0 

2.5 

2048K 

10.1 

5.0 

4096K 

16.9 

8.4 

8192K 

20.0 

10.2 

Table  1  — 

8K  CM-2 

Performance  in  Mbytes/second 

As  shown  in  Table  1,  it  takes  about  the  sarnie  time  (200  ms)  to  read  a  256K  block  a^  it  takes 
to  read  a  2048K  block.  The  same  observation  holds  for  writing  the  information  to  the  DataVault. 
The  largest  possible  block  sizes  will  yield  the  most  efficient  use  of  the  DataVault. 
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2.2  Gather/Scatter  Routines 


The  Gather/Scatter  routines  are  used  to  perform  general  communication  between  processors.  They 
are  particularly  useful  in  data  transfer  between  arrays  of  varying  dimension.  Figures  6  and  7 
illustrate  the  appropriate  syntax  for  the  Gather  and  Scatter  routines,  respectively. 

The  gather  package  of  routines  provide  a  general  gathering  operation  that  is  currently  not 
expressable  with  the  array  constructs  of  CM  Fortran.  This  gathering  operation  is  needed  when  data 
must  be  exchanged  between  processors,  requiring  general  interprocessor  communication.  Figure 
8  compares  the  Fortran  77  code  to  the  associated  library  call  demonstiating  the  purpose  of  this 
routine. 

The  destination  array  may  be  n-dimensional  and  routines  are  provided  for  the  source  being  1, 
2,  3,  or  4  dimensional.  The  destination  array(s)  and  index  arrays  must  have  the  same  subscript  list. 
Routines  are  provided  for  gathering  1,  2,  3,  or  4  arrays  (which  have  the  same  index  array(s))  at 
once  to  minimize  the  communication  time  involved.  Figure  9  contains  an  example  of  the  gatherl_2d 
routine  for  a  1  dimensional  destination  gathering  from  a  2  dimensional  source. 

The  scatter  package  of  routines  provide  a  general  scattering  operation  that,  similiar  to  the  gather 
operation,  is  currently  not  expressable  with  the  array  constructs  of  CM  Fortran.  This  scattering 
operation  is  needed  when  data  must  be  sent  to  other  processors,  requiring  general  interprocessor 
communication.  When  multiple  values  are  sent  to  the  same  processor,  an  add,  max,  or  min 
combining  operation  is  performed.  Figure  10  compares  the  Fortran  77  code  to  the  associated 
library  call  to  illustrate  the  function  of  this  routine. 

The  source  array  may  be  n-dimensional  and  routines  are  provided  for  the  destination  being  1, 
2,  or  3  dimensional.  As  with  the  gather  routines,  the  source  array  and  index  array (s)  must  have 
the  same  subscript  list.  Figure  11  demonstrates  the  usage  of  the  scatter_add_l  routine  for  a  2 
dimensional  source  scattering  to  a  1  dimensional  destination. 
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gat  her  1  _1  d  ( dest  ,index_l  ,so  urce_l  d ) 

gat  her2_l  d(  dest  1  ,dest  2  ,index_l  ,sourcel  _1  d  ,source2  _1  d ) 
gather3_ld(destl,dest2,dest3,index_l,sourcel_ld,source2_ld, 
source3_ld) 

gather4_ld(destl,dest2,dest3,dest4,index_l,sourcel_ld,source2_ld, 

source3_ld,source4_ld) 

gatherl_2d(dest,index_l,index_2,source_2d) 

gat  her2_2d(destl, dest  2, index.l, index  _2,sourcel_2d,source2_2d) 
gat  her3_2d(destl,dest2,dest3, index.l  ,index_2,sourcel_2d, 
source2_2d,source3_2d) 

gather4_2d(destl,dest2,dest3,dest4,index_l,index_2,sourcel_2d, 

source2_2d,source3_2d,source4_2d) 

gatherl_3d(dest,index_l,index_2,index_3,source_3d) 
gat  her2_3d(destl, dest  2,index_l, index  _2,index_3,sourcel_3d, 
source2_3d) 

gather3_3d(destl,dest2,dest3,index_l  ,index_2,index_3,sourcel_3d, 
source2_3d,source3_3d) 

gather4_3d(destl,dest2,dest3,dest4,index_l,index_2,index_3, 

sourcel_3d,source2_3d,source3_3d,source4_3d) 

gatherl_4d(dest,index_l,index_2,index_3,index_4,source_4d) 
gat  her2_4d(destl, dest2, index_l,index_2, index-3  ,index_4,sourcel_4d, 
source2_4d) 

gat  her3.4d(destl,dest2,dest3,  index.l  ,index_2,index_3,index_4, 
sourcel_4d,source2_4d,source3_4d) 
gather4_4d(destl,dest2,dest3,dest4,index_l,index_2,index_3,index_4, 
sourcel_4d,source2_4d,source3_4d,source4_4d) 

dest, dest I,dest2,dest3,dest4  :  integer  or  real  array  (n-dimensional) 
source_ld, sourcel.ld,source2_ld,source3_ld,source4.1d  :  integer/real  array  (ID) 
6ource.2d,sourcel_2d,source2_2d,source3-2d,source4-2d  :  integer/real  array  (2D) 
source.3d,sourcel_3d,source2_3d,source3-3d,source4_3d  :  integer/real  array  (3D) 
source_4d,8ourcel_4d,source2.4d,source3-4d,source4_4d  :  integer/real  array  (4D) 
index_14ndex.2,index_3, index.4  :  integer  array  _  _ 


Fig.  6  —  Gather  Routine)  Syntax 
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scat  ter_add_l  (dest_ld,index_l, source) 
scatter-add_2(dest_2d,index_l,index_2, source) 

scatter_add_3(dest  JJd,index_l,index_2,mdex_3,  source) 

scatter_min_l  (dest_l  d,index_l , source) 
scatter_min_2(dest_2d,index_l,index_2, source) 

scatter_min_3(dest_3d,index_l,index_2,index_3,source) 

scatter_max_l(dest_ld,index_l, source) 
scatter_max_2(dest_2d,index_l,index_2, source) 
scatter_max_3(dest_3d,index_l,mdex_2,index_3, source) 

source  :  integer/reai  array  (n  dimensional) 
dest_ld  :  integer/real  array  (1  dimensional) 
dest_2d  :  integer/real  array  (2  dimensional) 
destJld  :  integer/real  array  (3  dimensional) 
index_l,index_2,index_3  :  integer  array 


Fig.  7  —  Scatter  Routines  Syntax 


Fortran  77 

real  a(ml,m2),c(nl,n2) 
integer  i  j,ml,m2,nl,n2 
integer  index_l(ml,m2),index_2(ml,m2) 

do  i=l,ml 
do  j=l,m2 

a(i  j)  =  c(index.l(ij)4ndex_2(i  j)) 

enddo 

enddo 


Gather  Routine 

call  gatherl_2d(a,index_l,index_2,c) 


Fig.  8  —  Gather  Comparison 
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This  example  gets  the  diagonal  entries  of  the  2  dimensional  matrix  b  and  deposits  them 
in  the  one  dimensional  vector  a 

integer  ml,nl,n2 
parameter]  ml  =4, nl =4, n2=4) 

real  b(nl,n2),a(ml) 

integer  index _l(ml),index_2(ml ) 

index.1  =  [1:4] 
indexJ2  =  [1:4] 
b(  1 ,:)  =  [4.0,  6.0,  7.0.  9.0] 
b(2,:)  =  [7.0,  3.0,  6.0,  5.0] 
b(3,:)  =  [6.0,  5.0,  2.0,  9.0] 
b(4,:)  =  [5.0,  7.0,  6.0,  1.0] 

call  gatherl_2d(a,index_l,index_2,b) 

input  : 


/  4.0 

6,0 

7.0 

9.0  \ 

7.0 

3,0 

6.0 

5.0 

6.0 

5.0 

2.0 

9.0 

v  5.0 

7.0 

6.0 

1.0  ) 

output  : 


4.0 

3.0 

2.0 

1.0 


Fig  9  —  Gather  Example  for  a  ID  Destination  Gathering  from  a  2D  Source 
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Fortran  77 


Scatter  Routine 


real  a(ml,m2),c(nl,n2) 
integer  i J,ml,m2,nl,n2 
integer  index_l(nl,n2),index_2(nl,n2) 

do  i  =  l,nl 
do  j=l,n2 

a(index_l(ij),index_2(ij))  = 
a(index_l(ij),index_2(i  j))  +  c(ij) 
enddo 
enddo 


call  scatter  _add_2(a,index_l,index_2,c) 


Fig.  10  —  Scatter  Comparison 
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In  this  example  the  row  1  values  of  c  are  sent  and  accumulated  in  a(l),  values  in  rows 
2  and  3  of  r  are  accumulated  in  a(2),  and  values  in  row  4  of  c  are  accumulated  in  a(3). 
No  values  are  sent  to  a(4). 

integer  ml,nl,n2 
parameter(ml=4,nl=4,n2=4) 

real  c(nl,n2),a(mi) 
integer  index_l(ml) 

a  =  0.0 

index_l(l,:)  =  1 
index_l(2,:)  =  2 
index_l(3,:)  =  2 
index_l(4,:)  =  3 
c(  1 ,:)  =  [4.0,  2.0,  6.0,  3.0] 
c(2,:)  =  [1.0,  5.0,  7.0,  4.0] 
c(3,:)  =  [9.0,  8.0,  6.0,  4.0] 
c(4,:)  =  [4.0,  3.0,  7.0,  2.0] 

call  scatter.add_l(a,index_l,c) 

input  : 

/  4.0  2.0  6.0  3.0  \ 

1.0  5.0  7.0  4.0 

C~  9.0  8.0  6.0  4.0 

^  4.0  3.0  7.0  2.0  / 

output  : 


Fig.  11  —  Scatter  Example  for  a  2D  Source  Scattering  to  a  ID  Destination 


2.3  Sprint  Routines 


The  Sprint  routines  provide  a  simple  interface  to  the  indirect  addressing  hardware  on  the  CM. 
This  package  of  routines  should  be  used  for  an  array  whose  first  or  second  dimension  is  serial. 
Each  axis  of  an  array  may  be  set  up  to  be  parallel  or  serial  on  the  CM  with  a  layout  compiler 
directive  [2].  Parallel  or  serial  referring  to  the  programming  context  of  that  particular  axis.  To  use 
this  package  the  data  in  the  array  must  be  converted  to  a  suitable  format  by  calling  the  routine 
begin_fast .array.  Upon  finishing,  the  data  must  be  returned  to  the  normal  CMF  format  by  calling 
end  _fast-array.  Subroutine  fast  .array-access  performs  a  retrieval  operation  and  subroutine 
fast-array  .update  performs  an  updating  or  sending  operation.  The  two  dimensional  versions  of 
these  routines  are  fast_array-access_2d  and  fast -array  _update_2d.  Figure  12  illustrates  the 
appropriate  syntax  for  the  sprint  routines. 


begin-fast-array(array) 

fast -array-access(dest, array, index) 

fast -array _update(array, source, index) 

fast_array-access_2d(dest,array_2,indexl,index2) 

fast -array  _update_2d(array_2, source, indexl,index2) 

end-fast -array  (array) 

array  :  CM  integer  or  real  array  (first  dimension  serial) 
array_2  :  CM  integer  or  real  array  (first  two  dimensions  serial) 
dest, source  :  CM  integer  or  real  array 
index, indexl,index2  :  CM  integer  array 


Fig.  12  —  Sprint  Syntax 

Figure  13  compares  the  CM  Fortran  code  to  the  associated  library  calls  required.  The  first 
forall  corresponds  to  the  fast.array. access  routine  and  the  second  forall  to  the  fast-array. update 
routine. 


CM  Fortran 

real,  array(30,128,128)  ::  array 
real,  array (128, 128)  ::  dest, source 
integer,  array(  128,128)  ::  index 
integer  i 

forall  (i=l:n)  dest  =  array(index(i),:,:) 
forall  (i  =  l:n)  array(index(i),:,:)  =  source 


Sprint  Routines 

call  fast_array_access(dest,  array,  index) 
call  fast-array _update(array,  source,  index) 


Fig.  13  —  Sprint  Comparison 


The  parallel  dimensions  of  the  “source”,  “index”,  and  “array”  arguments  must  be  conformable. 
Figure  14  provides  an  example  setup  and  call  of  the  two  dimensional  sprint  routines. 


10 


This  example  demonstrates  an  access  and  update  of  an  array  using  the  sprint  calls, 
integer  dl,d2,d3,d4 

parameter  (dl  =  13,d2=15,d3=128,d4=128) 

integer  a(dl,d2,d3,d4) 
integer,  array(d3,d4)  ::  il,i2,b 


cmf$  layout  a(:serial,:serial, mews, mews) 
cmf$  layout  il(:news, mews), i2( mews, mews) 
cmf$  layout  b(:news,:news) 


c  generate  random  numbers  for  il  and  i2 
call  CMF_random(il,dl) 

11  =  il  +  1 

call  CMF_random(i2,d2) 

12  =  i2  +  1 


call  beginJast_array(a) 
call  fastj.iTay_access-2d(b,a,il,i2) 
call  fast_array_update_2d(a,b,il,i2) 
call  endJast_array(a) 


Fig.  14  —  Sprint  Example  for  two  dimen*ion$ 
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2.4  Table  Lookup 


The  routines  in  this  package  are  used  to  create  a  fast,  integer  or  real,  lookup  table,  extract  values 
from  the  lookup  table,  and  free  up  space  when  the  lookup  table  is  no  longer  needed.  The  routines 
provided  are  listed  in  Figure  15  with  their  appropriate  syntax. 


make  Jnteger_lookup(fe_int-array,  length) 
make_real_lookup(fe_real-array,  length) 

make  Jookup_cm(cmjsource_array, cm  Jndex, length, cm_mask) 

lookup(cm_dest_array,lookup_table,cmJndex,cm_mask) 

free_lookup(lookup_table) 

fe Jnt-array  :  front  end  integer  array 
fe_real_array  :  front  end  real  array 
cm.source_array  :  CM  real  or  integer  array 
cmjdest .array  :  CM  real  or  integer  array 
cm  index  :  CM  integer  array 
cm_mask  :  CM  logical  array 
length,  lookup-table  :  integer 


Fig.  15  —  Lookup  Table  Syntax 

The  lookup  table  can  be  initialized  from  a  front  end  array,  residing  in  front  end  memory,  or  from 
a  CM  array,  residing  in  CM  memory.  The  function  make_realJookup,  along  with  an  associated 
integer  version  make  Jnteger  Jookup,  create  a  lookup  table  with  initial  values  taken  from  a  front 
end  array  argument.  The  integer  function  makeJookup.cm  creates  a  lookup  table  with  initial 
values  taken  from  a  CM  array  argument.  A  CM  array’s  data  values  are  stored  in  CM  memory 
whereas  a  front  end  array’s  data  values  are  stored  in  front  end  memory. 

Subroutine  lookup  extracts  the  value  from  the  associated  table  entry.  When  the  lookup  table 
is  no  longer  needed,  subroutine  freeJookup  should  be  called  to  free  up  memory.  This  table  is 
appropriate  when  the  index  for  the  lookup  table  is  an  array  on  the  CM,  and  the  lookup  table  is 
the  same  for  every  processor. 

Figure  16  demonstrates  the  proper  usage  of  these  routines.  Function  make.cmJookup  creates  a 
lookup  table  using  initial  values  from  the  CM  array  “cm _source_array.”  The  call  to  makeJookup.cm 
copies  each  element  of  “cm_source_array”  to  a  location  in  the  lookup  table  as  specified  by  the 
“cm index”  corresponding  to  each  source  element.  This  occurs  where  the  values  of  the  logical  mask 
“cmjmask”  are  true.  This  masking  operation  simply  identifies  which  values  of  “cm_source_array” 
are  to  initialize  the  lookup  table. 

All  selected  elements  must  have  a  unique  table  index  “cmindex”  to  place  their  table  value 
“cm-source.array”.  Uninitialized  elements  of  the  lookup  table  will  be  set  to  0.  While  the  type 
of  “cm-source^array”  must  be  either  real  or  integer,  the  user  need  only  use  this  single  function. 
Unlike  the  front  end  array  initialization  routines,  make  Jnteger  Jookup  and  make.reaLlookup ,  only 
one  routine  is  needed  when  initializing  the  lookup  table  from  a  CM  array  (either  of  type  real  or 
integer);  an  integer  is  returned  that  identifies  the  table. 
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Values  are  extracted  from  the  lookup  table  and  assigned  to  the  CM  array  “cm_dest_array”  using 
subroutine  lookup.  This  routine  uses  the  table  index  “cmJndex”  to  extract  the  corresponding  table 
value  from  the  lookup  table  “mydookup-table.”  The  extracted  value  is  assigned  to  the  CM  array 
“cm_dest_array.” 

Finally,  when  the  lookup  has  been  accomplished,  the  memory  used  to  store  the  lookup  table 
must  be  deallocated  by  using  routine  freeJookup. 
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In  this  example,  values  from  the  cmjsource_array  initialize  the  lookup  table  and  are 
then  extracted  and  assigned  to  the  cm_dest_array. 

integer  nproc 
parameter(nproc=8) 

integer  myJookup_table 
integer,  array(nproc)  ::  cmJndex 
real,  array(nproc)  ::  cmjsource_array,  cm_dest_array 
logical,  array(nproc)  ::  cm_mask 

cm_source_array  =  [2.0,  4.0,  8.0,  1.0,  7.0,  6.0,  3.0,  9.0] 
cm_mask  =  .false. 
cnunask(l:nproc:2)  =  .true. 
cmJndex  =  [nproc:l:-l] 

myJookup.table  =  make  Jookup_cm(cm_source_array, cmJndex, nproc, cm_m  ask) 
cm-dest^array  =  20.0 

call  lookup(cm_dest-array, myJookup.table, cmJndex, cm_mask) 
call  freeJookup(myJookup.table) 

input  : 

cmsourcejarray  =  (  2.0  4.0  8.0  1.0  7.0  6.0  3.0  9.0  ) 
cmJndex  =  ^8765432l) 
cm-mask  =  (  T  FT  FT  FT  F  ) 

output  : 

cmJLestjarray  =  |  9.0  20.0  6.0  20.0  1.0  20.0  4.0  20.0  j 


Fig.  16  —  Table  Lookup  Example 
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2.5  Order 


The  order  routine  determines  the  ascending  ordering  of  real  or  integer  values  in  an  array  and 
generates  an  integer  array  of  index  values.  The  axis  parameter  is  the  array  axis  along  which  the 
ordering  is  required.  Figure  17  contains  the  proper  syntax  for  calling  order .  The  source  array  of 
values,  “cm_source_array”,  may  be  an  integer  or  real  array.  The  “cm_dest.array”  is  an  integer  array 
containing  the  indices  of  the  source  array  in  ascending  order.  The  “cmjmask”  is  an  integer  array 
whose  values  specify  whether  the  corresponding  value  of  “cm_source_array”  should  be  included  for 
ordering.  The  elements  of  ucm_mask”  should  be  set  to  1  for  inclusion  or  0  for  exclusion. 

On  return  from  order,  the  first  element  of  “cm_dest_array”  will  contain  the  integer  index  of  the 
source  array’s  smallest  value.  Figure  18  contains  a  one  dimensioned  example. 


order(cm_dest  .array,  cmjsource^array,  axis,  enunask) 

cm_dest_array  :  integer  array 
cm_source_array  :  real  or  integer  array 
cm_mask  :  integer  array 
axis  :  integer 


Fig.  17  —  Order  Syntax 
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In  this  example,  values  from  the  cm_source_array  are  ordered  in  ascending  order  and  the 
index  values  are  assinged  to  cm_dest -array.  The  values  of  cm_source_array  are  selected 
for  ordering  by  setting  the  corresponding  elements  of  cm_mask  to  1. 

integer  nproc 
parameter(nproc=8) 

integer  axis 

real,  array(nproc)  ::  cmjsource_array 
integer,  array(nproc)  ::  cmjdest_array,cm_mask 

cm_source_array  =  [4.0,  3.0,  6.0,  1.0,  2.0,  7.0,  9.0,  5.0] 
cm_dest_array  =  0 
axis  =  1 
cm_mask  =  1 

call  order(cm_dest_array,cm_source^array,axis,cm_mask) 
input  : 

cm^source-array  =  (  4.0  3.0  6.0  1.0  2.0  7.0  9.0  5.0  ) 

output  : 

cm.destja.rray  =  |4  52  1  8367| 


Fig.  18  —  Order  Example  -  ID 
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2.6  Scan  Functions 


The  functions  contained  in  this  package  are  used  for  parallel  operations  called  “scans,”  which 
combine  communication  and  calculation.  These  operations  are  very  powerful  in  that  they  allow 
combining  operations  or  calculations  to  be  performed  for  each  processor.  A  single  dimension  of  a 
multidimensional  array  may  be  scanned.  The  combining  operation  may  be  numerically  oriented 
(ADD,  PRODUCT,  MIN,  or  MAX)  or  logically  oriented  (OR,  AND  ,  or  XOR).  There  is  also  a 
special  scan,  “copy  scan,”  in  which  a  value  is  simply  copied  to  other  processors,  and  a  combining 
operation  is  not  performed.  A  pleasant  feature  of  the  “scans”  is  that  intermediate  results  are  com¬ 
puted  and  stored.  For  example,  if  a  total  sum  of  all  values  of  an  array  is  needed,  the  intermediate 
values  or  partial  sums  would  be  computed,  using  a  “sum  scan.”  Figure  19  demonstrates  what  is 
meant  by  “partial  sums." 


I  In  this  example,  values  from  vector  a  are  added  together  and  the  partial  sums  are  shown  | 
in  vector  b,  the  total  sum  of  a  is  38. 


a  =  (  2.0  5.0  3.0  5.0  7.0  8.0  2.0  6.0  ) 

6  =  [  2.0  7.0  10.0  15.0  22.0  30.0  32.0  38.0  ] 


Fig.  19  —  Partial  Sums  Example 

Figure  20  contains  a  list  of  all  6can  functions  and  their  associated  syntax.  The  naming  conven¬ 
tion  is  such  that  the  first  part  of  the  function  name  corresponds  to  the  combining  operation  to  be 
performed.  It  is  also  possible  to  start  the  scan  anew  at  various  points  by  assigning  an  element  of 
the  “sbit”  array  argument,  representing  the  start  bit,  to  true.  When  a  “true”  element  of  the  array 
“sbit”  is  encountered,  the  scan  is  started  over.  Some  of  these  operations  are  implemented  in  CM 
Fortran  through  reduction  intrinsics.  For  example,  the  CM  Fortran  compiler  generates  a  sum  scan 
for  the  “sum”  reduction  intrinsic.  However,  the  partial  sums  are  not  provided,  only  the  total  sum 
is  available. 

The  product_scan  is  restricted  to  read  values  and  the  logical  scans  (and-scan,  or_scan, 
xor_scan)  accept  only  logical  or  integer  arguments.  Sum_scan,  max_scan,  and  min_scan  are 
restricted  to  integer  or  real  values.  Copy  .scan  is  the  only  unrestricted  scan  because  it  does  not 
perform  a  combining  operation,  simply  a  copy.  The  “dir”  argument  indicates  the  direction  the  scan 
is  to  be  performed  along.  A  value  of  “true”  indicates  an  upward  or  forward  direction  whereas  “false” 
indicates  a  downward  or  backward  direction.  The  “dim”  argument  specifies  which  dimension  the 
scan  is  to  be  performed  along.  In  addition,  a  “mask”  may  be  used  to  specify  array  elements  which 
are  not  to  be  considered  in  the  scan. 

Figure  21  illustrates  how  the  scanning  process  works  for  the  sumscan.  Figure  22  illustrates  an 
upward  direction  producLscan. 
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product  _scan(real_result, real-source, dir, dim, sbit, mask) 
sum_s  can(result,  source,  dir,  dim,  sbit,  mask) 
max_scan(  result,  source,  dir,  dim,  sbit,  mask) 
min  jcan(result,source,dir, dim, sbit, mask) 
or_scan(logint_result,logint_source, dir, dim, sbit, mask) 
xor_scan(logint_result,logint_source,  dir,  dim,  sbit,  mask) 
and_scan(logint_result,logint_source,dir, dim, sbit, mask) 
copy  jscan(any  .result,  any_source,  dir,  dim,  sbit,  mask) 

real-result, real-source  :  real  array 

logint_result,logint_source  :  logical  or  integer  array 

any_result,any_source  :  integer,  logical,  or  real  array 

result, source  :  integer  or  real  array 

dir  :  logical 

dim  :  integer 

sbit, mask  :  logical  array 


Fig.  20  —  Scan  Syntax 
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In  this  example,  values  from  the  source  array  are  summed  in  the  corresponding  elements 
of  the  result  array  for  a  “dir”  argument  of  upward  and  downward.  Values  of  the  result 
are  set  only  for  the  true  values  of  the  mask.  A  new  scan  is  started  when  both  the  sbit 
and  mask  are  “true.” 

input  : 

source  =  (lllllllll 

1  1  1  1  1  1  1  ) 

mask  =  (TTTTFFFFT 

T  F  F  T  T  T  F  ) 

sbit  =  (fftffftff 

F  F  F  F  T  F  F  ) 

upward  direction  output  : 

result  =  |  1  2  1  2  -  -  -  -  3 

4  -  —  5  1  2  -  ] 

downward  direction  output  : 

result  =  |  3  2  1  5  -  —  —  —  4 

3  -  -  2  1  1  -  ] 

Fig.  21  —  General  Sum  Scan 
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In  this  example,  values  from  the  source  array  are  multiplied  in  the  corresponding  ele¬ 
ments  of  the  result  array  for  a  “dir”  argument  of  true  implying  upward  direction. 

integer  nproc 
parameter  (nproc  =  8) 

real,  array(nproc)  ::  result, source 
logical,  array(nproc)  ::sbit,cm_mask 

sbit  =  .false. 

cmjnask  =  .true. 

cm_mask(4:6)  =  .false. 

source  =  [.30,  .40,  5.0,  .50,  3.0,  4.0,  .10,  2.0] 

call  product_scan(result, source,. true. ,1, sbit, cm_mask) 

input  : 

source  =  (  .30  .40  5.0  .50  3.0  4.0  .10  2.0  ) 

cmjmask  =^TTTFF  FT  t) 

sbit  =  (FFFFFFFF  ) 
upward  direction  output  : 

result  =  [  .30  .12  .6  -  -  -  .06  .12 


22  —  Product  Scan  Example 
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3.  Graphics  Routines 


The  graphics  package  of  routines  allows  images  to  be  displayed  on  the  framebuffer  through 
simple  calls.  This  package  allows  a  user  to  display  images  without  dealing  with  the  intricacies  of 
the  low  level  framebuffer  calls  themselves. 


3.1  Framebuffer 

The  framebuffer  routines  are  used  to  display  pixels  on  the  framebuffer.  The  process  of  displaying 
an  image  consists  of  initialling  the  framebuffer,  setting  an  appropriate  color  map,  displaying  the 
pixels,  and  relinquishing  the  framebuffer. 

The  syntax  of  the  routines  in  this  package  are  listed  in  Figure  23. 


init_fb(x_size,y_size) 

release_frame_buffer( ) 

set  _color(color_id, red, green, blue) 

plot  _from^grid  (color) 

plot  _x_y(x,y, color, mask) 

plot  _x_y_over(x,y,color, mask) 

x_size,y  .size, color_id,red,green, blue  :  integer 

color  :  integer  array 

x,y  :  integer  or  real  array 

mask  :  logical  array 


Fig.  23  —  Framebuffer  Routtnet  Syntax 

Subroutines  init.fb  and  release_frame_buffer  initialize  and  release  the  framebuffer,  respec¬ 
tively.  Subroutine  set.color  allows  the  color  map  to  be  modified;  the  default  color  map  is  gray 
scale  from  0  (black),  to  255  (white).  Red,  green,  and  blue  can  each  range  from  0  to  255  giving  a 
total  of  16  million  possible  shades.  Color  0  is  the  background  color,  and  is  usually  left  black  (i.e. 
red=0,  green=0,  blue=0).  Figure  24  demonstrates  how  to  set  a  random  color  map  for  an  image. 


set_color(colorJd,  red,  green,  blue) 

integer  i 
do  i  =  1,32 

call  set_color(i,  mod(irand(0),256),mod(irand(0),256),mod(irand(0),256)) 
enddo 


Fig.  24  —  Framebuffer  let.cotor 

Subroutine  plot  .from  .grid  updates  a  single  pixel  to  a  specified  color  for  all  selected  processors, 
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which  must  be  arranged  in  a  2  dimensional  grid.  Figure  25  illustrates  a  sample  call. 


plot_from_grid(color) 

integer  heat(512,  512) 
heat  =128 

call  plot_from_gTid(heat) 


Fig.  25  —  Framebuffer  plot.jrom.grid 


Subroutine  plot_x_y  sets  each  pixel  to  a  specified  color,  clears  the  screen,  and  displays  the 
color  image.  The  plot_x_y_over  routine  is  a  variation  of  the  plot^c.y  routine  in  that  it  does  not 
refresh  the  screen  before  displaying  the  image.  Through  the  use  of  a  logical  mask,  subsections  of 
the  actual  image  may  be  selected  for  display.  Fig.  26  contains  an  example  call  to  ploLx.y,  with 
the  resulting  graphical  output  illustrated  in  Fig.  27. 


In  this  example,  the  color  map  is  filled  with  random  values  and  a  mask  is  used  to  select 
a  256  by  256  grid  in  the  upper  left  hand  corner  of  the  frambuffer. 

integer  npoints,xmax,ymax 
parameter(npoints=65536pcmax=256,ymax=256) 

integer  i,irand 

integer,  array(npoints)  ::  x_position,y -position, color 
logical,  array(npoints)  ::  mask 

call  init_fb(xmax,ymax) 
do  i= 1 ,32 

call  set_color(i,  mod(irand(0),256),  mod(irand(0),256),  mod(irand(0),256)) 
enddo 

**  call  cm  random  number  generator 
call  cmf_random(x.position,xmax) 
call  cmfjrandom(y_position,ymax) 
call  cmf_random(color,32) 

mask  =  x.position  .le.  256  .and.  y  .position  .le.  256 

call  plot_x.y-over(x_position,y  .position, color, mask) 
call  release  Jrame.buffer() 


Fig.  26  —  Framebuffer  Code  Example 


22 


23 


3.2  Plot 


The  plot  package  of  routines  provides  an  interface  to  the  framebuffer  similiar  to  unix  plot  functions. 
Coordinate  values  for  all  commands  are  reals  and  color  values  are  integers.  Mask  values  can  be 
integer  or  logical,  and  contain  a  1  in  all  array  elements  that  participate  in  a  draw  operation. 
Figure  28  contains  a  list  of  all  routines  in  this  package  along  with  the  appropriate  syntax.  Plural 
subroutines  take  conformable  array  arguments. 


openplQ 

closepl() 

eraseplQ 

set_color_value(colorJd,red,green,blue) 
set  -text  .size(size) 

space(scalar_xl,scalar_yl,scalar_x2,scalar_y2) 
line(scalar_xl  ,scalar_y  1  ,scalar_x2  ,scalar_y  2 , color) 
lines(array  _xl ,  array  _y  1 ,  array  _x2,array_y  2 , color, mask) 
circle(scalar_x, scalar  _y,r, color) 
circles(array_x,  array  _y,r,color,  mask) 
point  (scalar_x,scalar_y,  color) 
points(arrayjx,array_y, color, mask) 
label(string,length,scalar_x,scalar_y,  color) 

red, green, blue, size, length, color  jd  :  integer 

scalar _x, scalar _xl, scalar _x2  :  real 

scalar _y,scalar_yl, scalar _y2  :  real 

color  :  integer  array 

mask  :  logical  array 

string  :  character  string 

array _x, array _xl, array _x2  :  real  array 

array _y, array _y  1 , array _y 2  :  real  array 


Fig.  28  —  Plot  Routines  Syntax 


Subroutines  openpl,  closepl,  and  erasepl,  have  an  empty  parameter  list  and  simply  attach, 
detach,  and  erase  the  framebuffer  screen. 

After  attaching  the  framebuffer,  the  color  map,  text  size,  and  window  region  must  be  set.  The 
color  values  are  set  by  using  subroutine  set_color_value,  which  sets  an  integer  color  value  based 
on  a  red,  green,  and  blue  (rgb)  triplet.  Figure  29  sets  the  color  number  14  to  the  rgb  values  100, 
200,  300. 

Subroutine  set  .text  .size  allows  the  user  to  set  the  size  of  text  used  in  labeling  parts  of  the 
window.  The  six  sizes  currently  available  are  8,  10,  12,  14,  18,  and  24  point  corresponding  to  the 
input  integer  parameter  values  0  through  5. 

Subroutine  space  is  used  to  define  the  window  region  for  the  framebuffer.  The  default  setting 
is  (0.0, 0.0)  in  the  upper  left  hand  corner  of  the  screen  to  (1023.0,1023.0)  in  the  lower  right.  (xl,yl) 
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set_color_value(color,r,g,b) 
set_color_value(  14,100,200,300) 

Fig.  29  - —  Set.color.value  Example 


defines  the  new  upper  left  and  (x2,y2)  the  new  lower  right.  Figure  30  changes  the  window  region 
to  2048  by  2048. 


call  space(0. 0,0. 0,2048. 0,2048.0) 


Fig.  30  —  Space  Example 

Lines,  circles,  and  points  can  be  drawn  on  the  framebuffer  by  using  the  subroutines  line(s), 
circle(s),  and  point(s),  respectively.  Strings  of  text  may  be  drawn  by  use  of  subroutine  label. 
Figure  31  prints  the  word  “hello”  one  line  down  and  flush  left  of  the  screen  with  text  size  of  14 
point. 


label(string,length,x,y,  color) 

call  set_color_value(  1,255, 125, 125) 

call  set_text_size(3) 

call  label( ’hello’, 5, 0,14,1) 


Fig.  31  —  Label  Example 

Figure  32  contains  example  code  for  drawing  many  concentric  circles  with  the  corresponding 
graphical  output  shown  in  Fig.  33. 
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In  this  example,  many  concentric  circles  are  displayed 


real  x(512),y(512) 
integer  color(512) 
logical  mask(512) 

color  =  255 
mask  =.true. 
x  =  [1:512] 
y  =  512.0 
call  openplQ 

call  circles(x,y,x, color, mask) 
call  closepl() 


Fig.  32  —  Plot  Code  Example 


Fig.  33  —  Plot  Pictorial  Example 
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3.3  Surface 


The  surface  package  of  routines  provides  fast  surface  visualization  for  display  on  the  framebuffer. 
The  framebuffer  must  be  initialized  using  subroutine  t nit.fb  as  explained  in  Section  3.1  and  Figure 
23.  Figure  34  demonstrates  the  proper  syntax  for  calling  the  surface,  surface_over,  and  shade 
routines. 


surface  (z, color, theta, phi) 
surface.over  (z, color, theta, phi) 
shade  (dest,z, theta, phi) 

z  :  integer  or  real  array  (2  dimensional) 
color, dest  :  integer  array 
theta, phi  :  real 


Fig.  34  —  Surface  Routines  Syntax 

Subroutine  surface  displays  a  3  dimensional  surface  using  a  2  dimensional  source  and  associated 
shading  values.  Routine  surface.over  is  identical  to  the  surface  routine  except  that  it  plots  the 
surface  on  top  of  the  previous  contents  of  the  graphics  buffer.  The  “z”  value  is  a  real  two  dimensional 
square  array  of  elevations.  “Color”  is  an  array  conformable  to  “z”  which  contains  an  integer  color 
value  from  0  to  255.  As  shown  in  Section  3.1  and  3.2,  the  appearance  of  these  color  values  on 
the  screen  can  be  modified  using  the  set.color  or  set.color.value  routines.  The  “theta”  and  “phi” 
values  are  single  real  rotation  values  for  the  z-axis  and  x-axis  respectively. 

The  shade  routine  is  used  to  provide  a  shading  value  (without  shadows)  for  a  two  dimensionsal 
array  of  elevations  with  a  light  source  at  the  far  right  of  the  screen.  It  returns  an  integer  color 
value  from  0  to  255  in  the  destination  array.  As  in  subroutine  surface,  “theta”  and  “phi”  are  the 
rotations  about  the  z  and  x  axes. 

Figure  35  illustrates  an  example  for  calling  the  surface  library  package  of  routines  with  the 
graphical  output  shown  in  Fig.  36. 
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integer  lenl,len'2 
parameter(lenl  =  128,len2=128) 

real,  array  (lenl,len2)  ::  x,y,z 
integer,  array(lenl,len2)  ::  color 
integer  i 
real  theta 

x  =  spread([l:lenl],2,len2) 
y  =  spread([l:len2],l,lenl) 

z  =  cos(x*8.0*3.1415926365/128)+cos(y*8.0*3. 1415926365/128) 
z  =  z  *30.0 
theta  —  0.0 

call  init_fb( 256,256)  !  initialize  the  framebuffer 

do  i = 0, 1 00 
theta  —  theta  +  0.1 

call  shade  (color, z, theta, -0.7777)  !  set  up  the  shading  values 

call  surface  (z, color, theta, -0.7777)  !  plot  the  surface 

enddo _ 

Fig.  35  —  Surface  Code  Example 


# 


Fig.  36  —  Surface  Pictorial  Example 
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4.  Linear  Algebra  Routines 


The  Linear  algebra  package  of  routines  provides  a  user  with  specific  examples  of  programming 
matrix  operations  in  CM  Fortran.  The  linear  system  routines  will  be  supplanted  by  the  CMSSL 
routines  [7]  upon  release  from  TMC. 


4.1  Polynomial  Evaluation 

The  fast_poly  package  of  routines  are  used  to  evaluate  polynomials  using  Horner’s  rule.  Each 
processor  evaluates  a  polynomial  based  on  a  data  point  in  that  processor.  The  three  subroutines 
in  this  package  are  used  to  set  up  the  coefficients,  evaluate  the  polynomial,  and  free  up  space  when 
a  coefficent  is  no  longer  needed.  Figure  37  illustrates  the  proper  syntax  for  these  three  routines, 
make_horner_coef,  evaLhorner,  and  free_horner_coef. 


integer  function  make_horner_coeff(fe_coef_array, length) 

evaLhorner(cm_result,coef,cm_source) 

free_horner_coef(coef) 

cm_result,cm_source  :  real  CM  array 
fejcoef_array  :  integer  front  end  array 
length, coef :  integer 


Fig.  37  —  Fast  Poly  Routines  Syntax 

Figure  38  shows  how  to  evaluate  the  polynomial  2.1x3  +  0.5x 2  +  Ax  +  1.1  in  each  CM  processor. 
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In  this  example,  values  from  the  cm_source  are  evaluated  using  the  fe.coef_array  with 
results  stored  in  cm_dest_array. 

integer  length, nproc 
parameter(  length =4,nproc=8) 

real,  array(nproc)  ::  cm_source,cm_result 
integer,  array(length)  ::  fe_coef_array 
integer  coef 

fejcoef_array(l)  =  2.1 
fe_coef_array(2)  =  0.5 
fe.coef-array(3)  =  4.0 
fejcoeLarray(4)  =1.1 

cmjsource  =  [1.0,  2.0,  0.0,  3.0,  0.0,  2.0,  1.0,  1.0] 

coef  =  make_horner_coef(fe_coef_array)  !  form  coefficients 

call  eval_horner(cm_result,coef,cm-SOurce)  !  evaluate  at  each  point 

call  free_horner(coef)  !  free  up  space 

input  : 

cmsource  =  ^  1.0  2.0  0.0  3.0  0.0  2.0  1.0  1.0  ) 

output  : 

cmjiest  =  [  7.7  27.9  1.1  74.3  1.1  27.9  7.7  7.7  J 


Fig.  38  —  Fait  Polynomial  Example 
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4.2  Fast  Fourier  Transform 


The  purpose  of  the  fft  routine  is  to  provide  a  CM  Fortran  interface  for  the  Paris  complex  feist  fourier 
transform  routine.  A  complex  array  is  constructed  from  the  real  and  imaginary  (“re_source”  and 
“im_source”)  parts  and  passed  into  the  Paris  routine,  whereupon  the  real  and  imaginary  parts  are 
extracted  (“reddest”  and  “im.dest”)  on  return.  The  arrays  may  be  laid  out  in  send  or  news  order  in 
CM  memory  [3].  The  send  ordering  is  faster  than  the  associated  news  ordering  when  an  interface 
block  is  used  [2].  Figure  39  demonstrates  the  proper  syntax  for  calling  the  fft  routine. 


fft(re_dest,im_dest, re  .source, im_source,  operation) 

re_dest, im.dest, re_source, im_source  :  real  array 
operation  :  integer  array 


Fig.  39  —  FFT  Routine  Syntax 

Figure  40  gives  an  example  of  calling  the  fft  routine.  The  front  end  integer  array  “operation” 
indicates  the  transform  (none  =  0,  forward  =  1,  or  inverse  =  2)  to  be  performed  along  each  axis. 
The  size  of  the  operation  array  is  equal  to  the  rank  of  the  source/dest  arrays.  Arrays  are  laid  out 
in  send  order  through  the  use  of  the  layout  compiler  directive. 
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integer  nl,n2 
parameter(nl=64,n2=64) 

real,  array(nl,n2)  ::  re_dest,im_dest,re_source,im-source 
integer,  array(2)  ::  operation 

cmf$  layout  re_dest(:send,:send),im_dest(:send,:send) 
cmf$  layout  re_source(:send,:send),im_source(:send,:send) 
cmfS  layout  operation(:serial) 

interface 

subroutine  fft(re_dest,im_dest, resource, im_source, operation) 
integer  nl,n2  parameter(nl=64,n2=64) 
real,  array(nl,n2)  ::  rejdest,im_dest,rejBOurce,im_source 
integer,  array (2)  ::  operation 

cmf$  layout  re_dest(:send,:send),im_dest(:send,:send) 
cmf$  layout  re_source(:send,:send),im_source(:send,:send) 
cmfS  layout  operation(rserial) 

end  interface 

**  intialize  input  matrices 

call  cmf_random(re_source,0,0) 
call  cmf_random(im_source,0.0) 

**  perform  forward  transform  along  dimension  1 
**  and  no  transform  along  dimension  2 

operation(l)  =  1 
operation(2)  =  0 

call  fft(rejdest, im.dest, resource, im_source, operation) 


Fig.  40  —  Fast  Fourier  Transform  Example 
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4.3  Matrix  Multiply 


The  purpose  of  the  matmull  routine  is  to  provide  a  CM  Fortran  interface  for  the  Paris  matrix 
multiply  routine  which  allows  the  user  access  to  a  more  efficient  routine  than  the  CM  Fortran 
intrinsic  function  “matmul.”  However,  the  number  of  rows  and  columns  must  be  a  power  of  two 
and  the  number  of  elements  of  each  matrix  must  be  greater  than  or  equal  to  the  number  of  physical 
processors.  If  the  above  conditions  are  not  satisfied,  the  CM  Fortran  intrinsic  function  matmul  must 
be  used.  Figure  41  illustrates  the  proper  syntax  for  calling  matmull.  The  parameters  “matrix_a” 
and  “matrix.b”  are  input  and  the  result  is  returned  in  the  CM  array  “result.” 


mat  mull  (  mat  rix_a ,  mat  rix_b  ,res  ult ) 
matrix^., matrix.b, result  :  real  array  (2  dimensioned) 

Fig.  41  —  Matmull  Routine  Syntax 

Figure  42  demonstrates  an  example  call  to  subroutine  matmull. 


integer  m,n,p 
parameter(m=2,n=2,p=4) 

real  matrix_a(n,m),matrix_b(m,p),result(n,p) 

result  =  0.0 
matrix_a(l,:)  =  1.0 
matrix^a(2,:)  =  2.0 

matrix_b(l,:)  =  [4.0,  8.0,  4.0,  7.0] 
matrix_b(2,:)  =  [2.0,  1.0,  4.0,  3.0] 

call  matmull  (matrix^,  matrix.b,  result) 
input  : 


output  : 


solve 


( 


1.0  1.0 

2.0  2.0 


4.0 


2.0 


8.0  4.0 
1.0  4.0 


7.0 

3.0 


result  = 


6.0  9.0  8.0  10.0 

12.0  18.0  16.0  20.0 


Fig.  42  —  Matrix  Multiplication  Example 
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4.4  Linear  System  Routines 


Both  of  the  routines  in  this  library  package  will  be  included  in  the  CMSSL  library  package.  The 
linear  system  library  package  consists  of  a  linear  system  solver  and  a  matrix  inversion  routine.  The 
library  routine,  gauss,  solves  a  n  x  n  system  of  linear  equations  using  gaussian  elimination.  The 
input  matrix,  augmented  by  the  forcing  vector,  is  a  n  by  n+1  system.  On  return  the  forcing  vector 
is  overwritten  with  the  solution  vector.  The  matrix  is  stored  in  the  upper  left  hand  corner  of  the 
2  dimensional  grid. 

Subroutine  inv  computes  the  inverse  of  a  square  matrix,  using  a  form  of  gaussian  elimination. 
As  with  the  gauss  routine,  the  input  matrix  is  stored  in  the  upper  left  hand  corner  of  the  2 
dimensional  grid.  A  work  matrix,  of  size  n  by  2n,  made  up  of  the  input  matrix  augmented  by 
an  identity  matrix  is  used.  The  inverse  solution  overwrites  the  source  matrix  upon  return  from 
subroutine  inv. 

Figure  43  illustrates  the  proper  calling  procedure  for  subroutine  gauss  and  inv.  “N”  is  the 
dimension  of  the  system  and  “matrix”  is  the  actual  linear  system. 


gauss(n, matrix) 
inv(n, matrix) 

matrix  :  real  array  (2  dimensional) 
integer  :  n 


Fig.  43  —  Linear  Syttem  Routines  Syntax 

Figure  44  and  45  contain  examples  for  solving  a  linear  system  and  computing  the  inverse  of  a 
matrix,  respectively. 
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integer  n 
parameter(n=3) 

real  mat(n,n+l),forcing_vector(n),solution(n) 

mat(l,l:n)  =  [4.0,  6.0,  2.0] 
mat(2,l:n)  =  [1.0,  3.0,  5.0] 
mat(3,l:n)  =  [7.0,  1.0,  8.0] 
forcing-vector  =  [66.0,  66.0,  99.0] 


mat(:,n+l)  =  forcing-vector 
call  gauss(n,mat) 
solution  =  mat(:,n+l) 
input  : 


output  : 


/ 

solve 

\ 


4.0 

6.0 

2.0  \ 

(  si  \ 

/ 

66.0  \ 

1.0 

3.0 

5.0 

S2  = 

66.0 

7.0 

1.0 

8.0  ) 

\  53  / 

99.0  j 

solution 


3.0  ' 
6.0 
9.0 


Fig.  44  —  Linear  System  Solver  Example 
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integer  n 
parameter(n  =  2) 

real  a(n,n) 

a(l,:)  =  [7.0,  4.0] 
a(2,:)  =  [6.0,  3.0] 

call  inv(n,a) 
input  : 


output  : 


f  7.0  4.0  \ 
^  6.0  3.0  ) 


solution  = 


-1.0  4/3 

2.0  -7/3 


Fig.  45  —  Matrix  Inversion  Example 


4.5  Tridiagonal  Solver 

Subroutine  tridiag  solves  tridiagonal  systems  of  equations,  using  a  cyclic  reduction  algorithm  [9], 
in  log(n)  time,  n  being  the  number  of  equations.  The  data  is  stored  using  four  variables:  the 
diagonal,  the  upper,  the  lower,  and  the  right  hand  side. 

If  the  data  is  configured  as  a  one  dimensional  grid  then  a  single  system  of  equations  is  solved. 
If  the  data  is  configured  as  two  or  more  dimensions,  then  M  systems  are  solved  simultaneously, 
where  M  is  the  product  of  the  sizes  of  all  dimensions  greater  than  1. 

Figure  46  contains  the  syntax  for  the  tridiagonal  call. 


tridiag(solution,lower,diagonal,upper,rhs) 

so'ution, lower, diagonal, upper, rhs  :  real  array 


Fig.  46  —  Tridiagonal  Solver  Routine  Syntax 
F'igure  47  illustrates  an  example  call  to  subroutine  tridiag. 

The  tridiagonal  routine  works  on  diagonally  dominant  systems  very  well,  but  other  tridiagonal 
systems  may  lead  to  inaccurate  solutions  due  to  the  instability  in  the  cyclic  reduction  algorithm 
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This  example  solves  a  tridiagonal  system  of  order  4 
integer  size 
parameter(size= 4 ) 

real,  array(size)  ::  solution, lower, diagonal, upper, rhs 

lower  =  1.0 
upper  =  1.0 
diagonal  =  4.0 
rhs(l)  =  6.0 
rhs(2)  =  12.0 
rhs(3)  =  18.0 
rhs(4)  =  19.0 

call  tridiag( solution, lower, diagonal, upper, rhs) 
input  : 


solve 


4.0  1.0  0.0  0.0  \ 

i 

(  51  ^ 

{  60  ^ 

1.0  4.0  1.0  0.0 

s2 

12.0 

0.0  1.0  4.0  1.0 

s3 

18.0 

0.0  0.0  1.0  4.0  ) 

\  54  ) 

i,  19.0  ) 

output  : 


solution  = 


1.0 

2.0 

3.0 

4.0 


Fig.  47  —  Tridiagonal  Solver  Example 
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Appendix  A 
syntax 


DataVault  Routines 


dv_open(fd,path) 

dv_close(fd) 

dv_read(fd,buff) 

dv_write(fd,buff) 

dv_rewind(fd) 

dv  Jseek(fd, offset ) 

fd, offset  :  integer 

path  :  character  string 

buff  :  integer,  logical,  or  real  array 
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Gather  Routines 


gatherl_ld(dest,index_l,source_ld) 

gat  her2_ld(destl, dest2, index.1  ,sourcel_ld,source2_ld) 
gat  her3_ld(destl,dest2,dest3,  index  _l,sourcel_ld,source2_ld, 
source3_ld) 

gather4_ld(destl,dest2,dest3,dest4,index_l  ,sourcel_ld,source2_ld, 

source3_l  d  ,source4_l  d) 

gatherl_2d(dest,index_l,index_2,source_2d) 

gather2_2d(destl,dest2,index_l,index_2,sourcel_2d,source2_2d) 

gather3_2d(destl,dest2,dest3,index_l,index_2,sourcel_2d, 

source2_2d,source3_2d) 

gat  her4_2d(destl,dest2,dest3,dest4, index.1  ,index_2,sourcel_2d, 

source2_2d,source3_2d,source4_2d) 
gat  herlJJd(dest, index.1, index_2,index_3,source_3d) 

gather2_3d(destl,dest2,index_l  ,index_2,index_3,sourcel_3d, 
source2_3d) 

gat  her3_3d(destl, dest2, dest3, index.1, index_2,index_3,sourcel_3d, 
source2_3d,source3_3d) 

gat  her4_3d  ( dest  1  ,dest  2  ,dest3  ,dest4,index_l  ,index_2  ,index_3, 

sourcel_3d,source2_3d,source3JJd,source4_3d) 
gat  herl.4d(dest,  index_l,  index  _2,index_3,index_4,source_4d) 

gat  her2  _4d(  dest  1  ,dest  2  , index.1  ,index_2  ,index_3  ,index_4 , sour  cel  _4d , 
source2_4d) 

gather3_4d(destl,  dest  2, dest  3, index.1,  index  J2,  index_3,  index_4, 
sourcel_4d,source2_4d,source3_4d) 
gather4_4d(destl,dest2,dest3,dest4,  index.1  ,index_2,  index_3  ,index_4, 
sourcel_4d,source2_4d,source3_4d,source4_4d) 

dest,destl,dest2,dest3,dest4  :  integer  or  real  array  (n-dimensional) 
source.ld, sourcel_ld,source2_ld,source3_ld,source4_ld  :  integer/real  array  (ID) 
source_2d,sourcel_2d,source2-2d,source3_2d,source4_2d  :  integer/real  array  (2D) 
source_3d,sourcel_3d,source2.3d,source3_3d,source4-3d  :  integer/real  array  (3D) 
source_4d,sourcel_4d,source2_4d,source3_4d,source4_4d  :  integer/real  array  (4D) 
index.1 4ndex-24ndex_34ndex_4  :  integer  array 
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Scatter  Routines 


scatter-add_l(dest_ld,index_l, source) 
scatter  _add_2(dest_2d,index_l,index_2, source) 
scatter_add_3(dest_3d,index_l,  index  _2,  index_3,  source) 
scatter  _min_l(dest_ld,index_l, source) 
scatter  _min_2(dest  _2d,  index_l,  index_2 , source) 
scatter  _min_3(dest  _3d  ,index_l  ,index_2  , index-3 , source) 
scatter  _max_l(dest_ld,index_l, source) 
scatter_max_2(dest_2d,index_l,index_2, source) 
scatter  _max_3(dest_3d,index_l  ,index_2,index_3,  source) 

source  :  integer/real  array  (n  dimensional) 
dest.ld  :  integer/real  array  (1  dimensional) 
dest_2d  :  integer/real  array  (2  dimensional) 
dest_3d  :  integer/real  array  (3  dimensional) 
index_l,index_2,index-3  :  integer  array 


Sprint  Routines 


begin_fast^array(array) 

fast-array-access(dest,array,index) 

fast -array _update(array, source, index) 

fast  -array -access_2d(  dest , array _2  ,indexl  ,index2  ) 

fast  -array _update_2d(array_2, source, indexl,index2) 

end-fast -array(array) 

array  :  CM  integer  or  real  array  (first  dimension  serial) 
array_2  :  CM  integer  or  real  array  (first  two  dimensions  serial) 
dest, source  :  CM  integer  or  real  array 
index, indexl,index2  :  CM  integer  array 
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Table  Lookup  Routines 


make_int  ege  r  _lo  oku  p  (  fe  _i  nt  _a  r  ray,le  ngt  h  ) 
make_realJookup(fe_real-array,  length) 

make  Jookup_cm(cm_source-array,  cm  Jndex,  length,  cm_mask) 

lookup(cm_dest_array,lookup_table,cmJndex,cm_mask) 

freeJookup(lookup_table) 

feJnt_array  :  front  end  integer  array 
fe_real_array  :  front  end  real  array 
cm_source_array  :  CM  real  or  integer  array 
cm_dest_array  :  CM  real  or  integer  array 
cmJndex  :  CM  integer  array 
cm_mask  :  CM  logical  array 
length,  lookup.table  :  integer 


Order  Routine 


order(cm_dest  .array, cm_source_array, axis, cm_mask) 

cm_dest_array  :  integer  array 
cm-source .array  :  real  or  integer  array 
cm_mask  :  logical  array 
axis  :  integer 


Scan  Routines 


product_scan(real_result, real-source, dir, dim, sbit, mask) 
sum  jscan(result, source, dir, dim, sbit, mask) 
max  jscan(  result , source, dir, dim, sbit , mask) 
min_scan(result,  source,  dir,  dim,  sbit,  mask) 
or  jscan(logint_result,logint_source, dir, dim, sbit, mask) 
xor_scan(logint_result,logint_source, dir, dim, sbit, mask) 
and  jscan(logint_result,logint-source,  dir,  dim,  sbit,  mask) 
copy  _scan(any  .result, any-source,  dir,  dim,  sbit,  mask) 

real-result, real-source  :  real  array 
logint_result,logint_source  :  logical  or  integer  array 
anyjresult,  any  .source  :  integer,  logical,  or  real  array 
result, source  :  integer  or  real  array 
dir  :  logical 
dim  :  integer 

sbit, mask  :  logical  array  _ 
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Framebuffer  Routines 


init_fb(x_size,y_size) 

release _irame  buffer(^ 

set  .color(color_id, red, green, blue) 

plot_from_grid(color) 

plot  _x_y(x,y, color, mask) 

plot  _x_y_over(x,y,  color,  mask) 

x_size,y  .size, color-id, red, green, blue  :  integer 

color  :  integer  array 

x,y  :  integer  or  real  array 

mask  :  logical  array  _ 

Plot  Routines 

openpl() 

closepl() 

erasepl() 

set  _color_value(colorJd, red, green, blue) 
set_text_size(size) 

space(scalar_xl, scalar  _yl,  scalar  _x2,scalar_y2) 
line(  scalar  _xl  ,scalar_y  1 ,  scalar  _x2  ,scalar_y  2 , color  ) 
lines(array_xl , array  _yl ,  array _x2,array_y2,  color,  mask) 
circle(scalar_x,scalar_y,r,  color) 
circles(array_x,array_y,r, color, mask) 
point(scalarjc,scalar_y,color) 
points(array_x, array  _y, color, mask) 
label(string, length,  scalar  _x,scalar_y,  color) 

red, green, blue, size, length, colorJd  :  integer 

scalar  _x,scalar_xl,scalar_x2  :  real 

scalar.y,scalar.yl,scalar_y2  :  real 

color  :  integer  array 

mask  :  logical  array 

string  :  character  string 

array _x, array _xl, array _x2  :  real  array 

array_y,array.yl,array_y2  :  real  array _ 
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Surface  Routines 


surface  (z, color, theta, phi) 
surfsc?  (z,color,t heta,phi) 

shade  (dest,z, theta, phi) 

z  :  integer  or  real  array  (2  dimensional) 
color, dest  :  integer  array 
theta, phi  :  real 

Polynomial  Evaluation  Routines 

integer  function  make_horner_coeflf(fe_coefLarray, length) 

eval_horner(cm_result,coef,cm-source) 

free  _hor  ner_coef(  coef ) 

cm_result,cm_source  :  real  CM  array 
fe_coef_array  :  integer  front  end  array 
length, coef :  integer 

Fast  Fourier  Transform  Routines 

fft(re  _dest  ,im_dest,re_source,im_source,  operation) 

re_dest,imjdest,re_source4m_source  :  real  array 
operation  :  integer  array 
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Matrix  Multiply  Routines 


mat  mull(  matrix_a,  mat  rix_b,  result) 
matrix_a,matrix_b, result  :  real  array  (2  dimensional) 


Linear  Systems  Routines 


gauss(  n,mat  rix) 
inv(n,  matrix) 

matrix  :  real  array  (2  dimensional) 
integer  :  n 


Tridiagonal  System  Routines 

tridiag(solution,lower,diagonal,upper,rhs) 
solution, lower, diagonal, upper, rh6  :  real  array 
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Appendix  B 
source 


Bl  DataVault  Routines 

SUBROUTINE  DV_OPEN(UNIT,  PATH) 

CHARACTER* (*)  PATH 
INTEGER  UNIT 

CALL  _DV_OPEN_C(PATH ,  UNIT) 

RETURN 

END 

SUBROUTINE  DV_READ(UNIT,  DEST) 

INTEGER  UNIT,  DEST 

INCLUDE  ’/uar/include/cin/paria-conf iguration-fort .h* 

INCLUDE  ' /usr/include/cm/CMF_def s .h’ 

INTEGER  DEST.TYP.  DEST. VPS,  LENGTH 
DEST. VPS  *  CMF.GET_VP_SET.ID (DEST) 

DEST.TYP  *  CMF.GET.DATA.TYPE(DEST) 

IF  (DEST.TYP  .Eq.  CMF.FLOAT)  THEN 
LENGTH  *  (CMF_GET_SIGNIFICAND_LEN(DEST)  + 

+  CMF.GET.EXPONENT.LEN (DEST)  +  1) 

CALL  _DV_READ_C(UNIT,CMF_GET_FIELD_ID(DEST) , LENGTH, DEST.VPS) 
ELSE  IF  ((DEST.TYP  .Eq.  CMF.U. INTEGER)  .OR. 

+  (DEST.TYP  .Eq.  CMF.S. INTEGER))  THEN 

CALL  _DV_READ_C(UNIT ,  CMF.GET.FIELD.ID(DEST) ,  32,  DEST.VPS) 

ELSE  IF  (DEST.TYP  .Eq.  CMF.LOGICAL)  THEN 

CALL  .DV.READ.C (UNIT ,  CMF.GET_FIELD.ID (DEST) ,  1,  DEST.VPS) 

ELSE  IF  (DEST.TYP  .Eq.  CMF.COMPLEX)  THEN 
LENGTH  «=  2*(CMF_GET_SIGNIFICAND_LEN(DEST)  ♦ 

♦  CMF.GET.EXPONENT.LEN (DEST)  ♦  1) 

CALL  .DV.READ.C (UNIT,  CMF.GET.FIELD.ID(DEST) ,  LENGTH,  DEST.VPS) 
END  IF 

CALL  CMF.set.is.modif ied(dest .MODIF) 

RETURN 

END 


SUBROUTINE  DV_WRITE(UNIT,  SRC) 

INTEGER  UNIT,  SRC 

INCLUDE  ’/usr/include/cm/paris-conf iguration-fort .h’ 
INCLUDE  ’ /usr/include/cm/CMF_def 8 .h’ 
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INTEGER  SRC.TYP,  SRC.VPS,  LENGTH 
SRC.VPS  =  CMF.GET_VP.SET_ ID (SRC) 

SRC.TYP  =  CMF. GET.DATA.TYPE ( SRC ) 

IF  (SRC.TYP  .EQ.  CMF.FLOAT)  THEN 
LENGIh  =  (CMF_GEi_SIGNIFICAND_LEN(SRC)  + 

+  CMF.GET.EXPONENT.LEN (SRC)  +1) 

CALL  _DV_WRITE_C(UNIT,CMF_GET_FIELD_ID(SRC) .LENGTH, SRC. VPS) 
ELSE  IF  ((SRC.TYP  .EQ.  CMF.U.INTEGER)  .OR. 

♦  (SRC.TYP  .EQ.  CMF.S. INTEGER))  THEN 

CALL  _DV_WRITE_C(UNIT,  CMF.GET.FIELD.ID(SRC) ,  32,  SRC.VPS) 

ELSE  IF  (SRC.TYP  .EQ.  CMF.LOGICAL)  THEN 

CALL  .DV.WRITE.C (UNIT ,  CMF.GET.FIELD.ID(SRC) ,  1,  SRC.VPS) 

ELSE  IF  (SRC.TYP  .EQ.  CMF.COMPLEX)  THEN 
LENGTH  «  2*(CMF_GET_SIGNIFICAND_LEN(SRC)  + 

+  CMF.GET.EXPONENT.LEN (SRC)  +  1) 

CALL  .DV.WRITE.C (UNIT,  CMF.GET.FIELD.ID(SRC) ,  LENGTH,  SRC.VPS) 

END  IF 

RETURN 

END 

SUBROUTINE  DV.CLOSE(UNIT) 

INTEGER  UNIT 

CALL  .DV.CLOSE.C(UNIT) 

RETURN 

END 

SUBROUTINE  DV.REWIND(UNIT) 

INTEGER  UNIT 

CALL  .DV.LSEEK.C (UNIT , 0) 

RETURN 

END 

SUBROUTINE  DV.LSEEK (UNIT, OFFSET) 

INTEGER  UNIT, OFFSET 

CALL  .DV.LSEEK.INCR.C (UNIT, OFFSET) 

RETURN 

END 


f include  <string.h> 
f include  <stdio.h> 
•include  <cm/paris .h> 
•include  <an/cmfs.h> 
•include  <cm/cm_file.h> 
•include  <cm/cm_errno.h> 

•if  def ined(sparc) 
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#  define  DV_OPEN_C  dv_open_c_ 

#  define  DV_LSEEK_C  dv_lseek_c_ 

#  define  DV_LSEEK_INCR_C  dv_lseek_incr_c_ 

#  define  DV_READ_C  dv_read_c_ 

#  define  DV_WRITE_C  dv_write_c_ 

#  define  DV_CLOSE_C  dv_close_c_ 

#endif 

#if  def ined(sparc) 

struct  ftn.string  {char  str[256]}; 

#else 

struct  ftn.string  {short  len;  char  *  str}; 
#endif 

char  *for2c_string(forstr) 
struct  ftn_string  *forstr; 

{ 

int  i,  true.len; 
char  *name_dref ,  *temp,  *rtn; 
tif  def ined(sparc) 
i  «=  255; 

*else 

i  ■  for8tr->len; 

#endif 

name.dref  *  forstr->str; 
true.len  =  0; 
temp  *  name_dref; 

while  ( (i — )  44  (*temp++  !=  ’  ’))  { 
true_len++ ;  >; 

rtn  *  temp  =  (char  *)  malloc(true_len+l) ; 
name.dref  =  forstr->str; 
i  *  true.len; 

*(temp+true_len)*0; 

while  ((i — )  44  (*name_dref  !=  ’  ’))  { 
*temp+*  *  *name_dref++;  >; 

/*  add  terminating  null  to  end  of  string  */ 
*temp  ■  0; 
return(rtn) ; 

> 

void  CMFS_perror() ; 
int  CMFS.errno; 

void  dv.openO ; 
void  dv.lseekO; 
void  dv_read(); 
void  dv.vriteQ; 
void  dv_cl08e(); 
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void  dv.unlinkO  ; 


•ief ine  S.ISUID  04000 
•define  S.ISGID  02000 
#def ine  S.ISVTX  01000 
•define  S.IRUSR  00400 
•define  S.IWUSR  00200 
•define  S.IXUSR  00100 
•define  S.IRWXG  00070 
•define  S.IRWXO  00007 

static  char  *file_name[101]  ; 
static  int  units [101]; 

void  DV_OPEN.C(name ,  open.retum) 
int  *open_return; 
struct  ftn.string  *name; 

{ 

f ile_name[*open_return]  *  for2c_string(name) ; 


static  void  actually_open_the_f ile(unit) 
int  unit; 

int  fd; 

fd  *  CMFS_open(f ile_name[unit]  ,  (CM.RDWR  I  CM.CREAT) ,  (S.IRUSR  I  S.IWUSR), 
CM.physical.processors.limit ,  CM.user.number.of .processors.limit) ; 
free(f  ile.name [unit] ) ; 
f ile.name [unit]  ■  0; 
if  (fd  **  -1)  { 

fprintf (stderr,  "OPEN  FAILED. \n  ERROR  IS:"); 
CMFS.perrorC'actually.open.the.f ile") ; 
exit(CMFS.errno) ; 

>; 

units [unit]  *  fd; 


void  DV_LSEEK_C(fd,off set) 
int  *fd,*offset; 

{ 

FILE  *my_stderr; 

int  lseek.return; 

if  (f ile.name [*fd] )  return; 

lseek.return  =  CMFS_lseek(units [*fd] ,  ^offset,  0) ; 
my.stderr  ■  stderr; 
if  (lseek.return  ==  -1)  { 

CMFS_perror("l8eek") ; 
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fprintf (my.stderr,  "REWIND  FAILED. \n  ERROR  IS:"); 
exit(CMFS_errno) ; 

>; 

> 


void  DV_LSEEK_INCR_C(fd, offset) 
int  *fd,*offset; 

{ 

FILE  *my_stderr; 

int  lseek.retum; 

if  (f  ile.nameOfd] )  return; 

lseek.retum  *  CMFS_lseek(units [*f d] ,  *offset,  1); 
my.stderr  *  stderr; 
if  (lseek.retum  =*  -1)  { 

CMFS_perror("lseek") ; 

fprintf (my.stderr,  "REWIND  FAILED. \n  ERROR  IS:"); 
exit(CMFS.errno) ; 

>; 


void  DV_READ.C(fd,  buff,  nbits,  dest.vps) 
int  *fd,  *buff,  mbits,  *dest_vps; 

FILE  *my_stderr; 
int  read.return; 

CM_set_vp_set(*dest_vps) ; 

if  (f ile_name[*fd] )  actually.open.the.f ile(*f d) ; 
read.return  *  CMFS.read.f ile.always (units [*fd]  ,  *buff,  mbits); 
my.stderr  «  stderr; 
if  (read.return  ■■  -1)  { 
fprintf (my.stderr,  "READ  FAILED. \n  ERROR  IS:  "); 
CMFS_perror("read") ; 
exit(CMFS.errno) ; 

>; 


void  DV_WRITE_C(fd,  buff,  nbits,  dest.vps) 
int  *fd,  *buff,  mbits,  *dest_vps; 

FILE  my.stderr; 
int  write.retum; 

CH_8et_vp_8et(*dest_vps) ; 

if  (f ile_name[*fd] )  actually.open.the.f ile(*fd) ; 

write.retum  *  CMFS.write.file.always (units [*fd] ,  *buff  .mbits) ; 

my.stderr  *  stderr; 

if  (write.retum  ==  -1)  { 

fprintf (my.stderr, "WRITE  FAILED. \n  ERROR  IS:"); 
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CMFS_perror("write") ; 
exit(CMFS_errno) ; 

>; 


void  DV_CLOSE_C(fd) 
int  *fd; 

{ 

FILE  *my_stderr; 
int  close.return; 

close_return  *  CMFS.close (units [*fd] ) ; 
my_stderr  *  stderr; 
if  (close_return  ==  -1)  { 

fprintf (my.stderr,  "CLOSE  FAILED. \n  ERROR  IS:"); 
CMFS_perror( "close") ; 
exit(CMFS_errno) ; 

>; 
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B2  Gather/Scatter  Routines 


subroutine  gatherl_ld(dest , index.l , source) 

include  ’/usr/include/cm/paris-conf iguration-fort .h’ 
include  1 /usr/include/ cm/ CKF_def s . h ’ 

c  compute  dest  =  source ( index. 1) 

c  gets  source  (1-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 

c  dest  :  real  destination  field;  n-dimensional 

c  index.l  :  integer  field  ;  first  index  of  source  array 

c  source  :  real  source  field;  1-dimensional 

integer  dest ,dest_id,dest_vp_set,dest_geo 
integer  index_l,index_l_id 

integer  source , source.id , source.vp.set , source.geo 
integer  get.field, length, temp.il 
integer  i.rank 

dest.id  =  cmf_get_field_id(dest) 
index_l_id  *  cmf_get_field_id(index_l) 
source.id  *  cmf .get. field. id (source) 

if  (dest.id  .eq.  0)  then 
print  *, 

+’ Error,  the  dest  argument  to  gather 1. Id  is  not  on  the  CM’ 
stop 
endif 

if  (index.l.id  .eq.  0)  then 
print  * , 

+’Error,  the  index.l  argument  to  gatherl.ld  is  not  on  the  CM’ 
stop 
endif 

if  (source.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source  argument  to  gatherl.ld  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  -  cmf _get_vp_set_id(dest) 
dest.geo  =  cm_vp_set_geometry(dest_vp_set) 

source.vp.set  *  cmf _get_vp_set_id(source) 
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source.geo  =  cm_vp_set_geometry(source_vp_set) 

call  cm_set_vp_set(dest_vp_set) 

get.field  =  cm.allocate.stack.f ield(32) 
temp  =  cm.allocate.stack.f ield(32) 
il  =  cm_allocate_stack_f ield(32) 

c  select  context  for  destination 

call  cm_set_context() 

call  cm.my.nevs.coordinate. 11 (temp, 0,32) 
call  cm_u_eq_constant_ 11 (temp, 0,32) 
call  cm.logand.context.with.testO 

rank  «  cm_geometry_rank(dest_geo) 
do  i=l, rank-1 

length  =  cmf_get_axis_extent(de8t,i-l) 
call  CM_my_news_coordinate_lL(temp , i , 32) 
call  CM_u_lt_constant_ 1L (temp , length , 32) 
call  CM.logand.context.vith.testO 
enddo 

call  cm.u.move_zero_always_ll(get_field,32) 
call  cm_u_subtract_constant_3_ll(il, index. l.id, 1,32) 
call  cm_deposit_news_coordinate.ll(source.geo,  get.field, 1, 
+  il ,32) 

call  cm_get_ll(dest_id,get_f ield, source. id, 32) 

call  cm.deallocate.stack.throughCget.f ield) 
call  CMF.set.is.modif ied(dest ,M0DIF) 
return 
end 


subroutine  gather2_ld(destl ,  dest2,  index.l,  sourcel,  source2) 

include  ’ /usr/include/cm/paris-conf igurat ion-fort .h’ 
include  ’/usr/include/cm/CMF.defs ,h’ 

c  compute  destl  ■  8ourcel( index.l) 
c  dest2  ■  source2(index_l) 

c 

c  gets  source  (1-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 

c  destl  :  real  destination  field;  n-dimensional 

c  dest2  :  real  destination  field;  n-dimensional 
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index. 1  :  integer  field  ;  first  index  of  source  array 

sourcel  :  real  source  field;  1-dimensional 

source2  :  real  source  field;  1-dimensional 

integer  destl,  dest2 
integer  sourcel,  source2 
integer  destl.id,  dest2_id 
integer  dest.vp.set .dest.geo 
integer  index. 1, index. l_id 
integer  sourcel.id,  source2_id 
integer  source.vp.set, source.geo 
integer  get .field, length, temp.il 
integer  i.rank 

integer  source.temp.id,  dest.temp.id 

destl.id  *  cmf.get.f ield.id(destl) 
dest2.id  *  cmf.get.f ield_id(dest2) 

index.l.id  «  cmf_get_field_id(index.l) 
sourcel.id  *  cmf.get.f ield.id(sourcel) 
source2_id  *  cmf_get_field_id(source2) 

if  (destl.id  .eq.  0)  then 
print  *, 

♦’Error,  the  destl  argument  to  gather2_ld  is  not  on  the  CM’ 
stop 
endif 

if  (dest2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest2  argument  to  gather2_ld  iB  not  on  the  CM’ 

8tOp 

endif 

if  (index.l.id  .eq.  0)  then 
print  ♦, 

♦’Error,  the  index. 1  argument  to  gather2_ld  is  not  on  the  CM 

8tOp 

endif 

if  (sourcel.id  .eq.  0)  then 
print  * , 

♦’Error,  the  sourcel  argument  to  gather2_ld  is  not  on  the  CM 
stop 
endif 


if  (source2_id  .eq.  0)  then 


print  *, 

♦’Error,  the  sovirce2  argument  to  gather2_ld  is  not  on  the  CM’ 
stop 
endif 

dest_vp_set  =  cmf _get_vp_set_id(destl) 
dest.geo  =  cm_vp_set_geometry (dest_vp_set) 

source_vp_set  =  cmf _get_vp_set_id(sourcel) 
source_geo  =  cm_vp_set_geometry(source_vp_set) 
call  cm_set_vp_set(source_vp_set) 
source_temp_id  =  CM_allocate_stack_f ield(2*32) 
call  CM_u_move_lL(source_temp_id,  sourcel.id,  32) 
call  CM_u_move_lL(source_temp_id  ♦  32,  source2_id,  32) 

call  cm_set_vp_set(dest_vp_set) 

get.field  *  cm_allocate_stack_f ield(32) 
temp  «=  cm_allocate_stack_f ield(32) 
il  ■  cm_allocate_stack_f ield(32) 
call  cm_set_contert() 

dest_temp_id  *  CM_allocate_stack_field(2*32) 

c  select  context  for  destination 

call  cm_my_news. coordinate. 11 (temp ,0,32) 
call  cm_u_eq_constant_ 11 (temp ,0,32) 
call  cm_logand_context_with_test() 

rank  =  cm_geometry_rank(dest_  j) 
do  i*l, rank-1 

length  *  cmf _get_axis_extent(destl ,i-l) 
call  CM_my_news_coordinate_lL(temp , i ,32) 
call  CM_u_lt_constant_ lL(temp, length, 32) 
call  CM_logand_context_uith_test() 
enddo 

call  cm_u_move_zero_always_ 11 (get _f ield , 32) 

call  cm_u_subtract_constant_3_ll(il , index.l.id, 1 ,32) 

call  cm_deposit_news_coordinate_ll(source_geo,  get_field,l, 

♦  il ,32) 

call  cm_get_ 11 (dest.temp.id ,get_f ield , source.temp.id , 2*32) 
call  CM_u_move_lL(destl_id,  dest_temp_id,  32) 
call  CM_u_move_lL(dest2_id,  dest.temp.id  ♦  32,  32) 

call  cm_deallocate_stack_through(dest_temp_id) 
call  CMF_set_is_modif ied(destl ,M0DIF) 
call  CMF_set_is_modif ied(dest2,M0DIF) 
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return 

end 


subroutine  gather3_ld(destlf  dest2,  dest3,  index. 1, 

+  sourcel,  source2,  source3) 

include  ’ /usr/include/cm/paris-conf iguration-f ort .h’ 
include  ’ /usr / include/ cm/CMF  _def s .  h  ’ 

c  compute  dest  =  source(index_l) 

c  gets  source  Cl-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 

c  destl  :  real  destination  field;  n-dimensional 

c  dest2  :  read  destination  field;  n-dimensional 

c  de8t3  :  real  destination  field;  n-dimensional 

c  index. 1  :  integer  field  ;  first  index  of  source  array 

c  sourcel  :  real  source  field;  1-dimensional 

c  source2  :  real  source  field;  1-dimensional 

c  source3  :  real  source  field;  1-dimensional 

integer  destl,  dest2,  dest3 
integer  sourcel,  source2,  source3 
integer  destl.id,  dest2_id,  dest3_id 
integer  dest.vp.set .dest.geo 
integer  index. 1, index. 1. id 
integer  sourcel.id,  source2_id,  source3_id 
integer  source.vp.set.source.geo 
integer  get.f ield, length, temp , il 
integer  i.rank 

integer  source.temp.id,  dest.temp.id 

destl.id  *  cmf .get.f ield.id(destl) 
dest2_id  *  cmf _get.field_id(dest2) 
dest3_id  *  cmf .get.f ield_id(dest3) 

index.l.id  ■  cmf _get_field_id(index_l) 
sourcel.id  =  cmf .get.f ield.id(sourcel) 
source2_id  ■  cmf _get_field_id(source2) 
source3_id  *  cmf .get.f ield_id(source3) 

if  (destl.id  .eq.  0)  then 
print  *, 

+’ Error,  the  destl  argument  to  gather3_ld  is  not  on  the  CM’ 
8t0p 
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endif 


if  (dest2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest2  argument  to  gather3_ld  is  not  on  the  CM’ 
stop 
endif 

if  (dest3_id  .eq.  0)  then 
print  *, 

+’ Error,  the  dest3  argument  to  gather3_ld  is  not  on  the  CM* 
stop 
endif 

if  ( index. 1_ id  .eq.  0)  then 
print  *, 

♦’Error,  the  index.l  argument  to  gather3_id  is  not  on  the  CM’ 
stop 
endif 

if  (sourcel.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source 1  argument  to  gather3_ld  is  not  on  the  CM’ 
stop 
endif 

if  (source2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source2  argument  to  gather3_ld  is  not  on  the  CM’ 
stop 
endif 

if  (source3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source3  argument  to  gather3_ld  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  •  cmf _get_vp_set_id(destl) 
dest.geo  *  cm. vp.set.geometry (dest.vp.set) 

source.vp.set  *  cmf _get_vp_set_id(sourcel) 
source.geo  =  cm_vp_set_geometry(source_vp_set) 
call  cm_8et_vp_set (source.vp.set) 
source.temp.id  *  CM.allocate.stack.f ield(3*32) 
call  CM_u_move_lL(source_temp_id,  sourcel.id,  32) 
call  CM_u_move_lL(source_temp_id  ♦  32,  source2_id,  32) 
call  CM_u_move_lL(source_temp_id  +  64,  source3_id,  32) 
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call  cm_set_vp_set(dest_vp_set) 


get.field  *  cm_allocate_stack_f ield(32) 
temp  =  cm.allocate.stack.f ield(32) 
il  *  cm_allocate_stack_f ield(32) 
call  cm.set.contextQ 

dest_temp_id  =  CM.allocate.stack.f ield(3*32) 

c  select  context  for  destination 

call  cm jmy.news.coordinate. 11 (temp , 0 , 32) 
cadi  cm_u_eq_con8tant_ 11 (temp, 0,32) 
call  cm_logand_context.«ith_test() 

rank  *  cm_geometry_rank(dest_geo) 
do  i*l, rank-1 

length  *  cmf_get_axis_extent(destl ,i-l) 
call  CM_my_news_coordinate.lL (temp ,i,32) 
call  CM_u_lt_constant_lL(temp .length, 32) 
call  CM_logand_context_with_test() 
enddo 

call  cm_u_move_zero_always_ 11 (get_f ield , 32) 
call  cm_u_subtract_constant_3_ll(il , index.l.id, 1 ,32) 
call  cm_depo8it_news_coordinate_ll(source_geo,  get_field,l, 
+  il ,32) 

call  cm_get_ll(dest_temp_id,get_field,source_temp_id,3*32) 
call  CM_u_move_lL(destl_id,  dest_temp_id,  32) 
call  CM_u_move_lL(dest2_id,  dest_temp_id  +  32,  32) 
call  CM,u_move_lL(dest3_id,  dest.temp.id  +  64,  32) 

call  cm_deallocate_8tack_through(dest_temp_id) 

call  CHF.8et_i8_modif ied(destl,MODIF) 

call  CMF_set_is_modif ied(dest2,M0DIF) 

call  CMF.set.is.modif ied(dest3,M0DIF) 

return 

end 


subroutine  gather4_ld(destl ,  dest2,  dest3,  dest4,  index.l, 
+  sourcel,  source2,  source3,  source4) 

include  ’/usr/include/cm/paris-configuration-fort.h’ 
include  ’ /usr/include/cm/CMF_def s .h* 

c  compute  dest  *  source (index.l) 

c  gets  source  (1-dimensional)  for  dest  (n-dimensional) 
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c  the  dest 
c 

c  parameters 
c  destl 

c  dest2 

c  dest3 

c  dest4 

c  index. 1 

c  source 1 

c  source2 

c  source3 

c  source4 


and  index  fields  must  be  in  the  same  vp  set 


:  real  destination  field;  n-dimensional 
:  read  destination  field;  n-dimensional 
:  real  destination  field;  n-dimensional 
:  real  destination  field;  n-dimensional 
:  integer  field  ;  first  index  of  source  array 
:  real  source  field;  1-dimensional 
:  real  source  field;  1-dimensional 
:  real  source  field;  1-dimensional 
:  real  source  field;  l-dimensional 


integer  destl,  dest2,  dest3,  dest4 
integer  sourcel,  source2,  source3,  source4 
integer  destl.id,  dest2_id,  dest3_id,  dest4_id 
integer  dest_vp_set,dest_geo 
integer  index. 1, index. l.id 

integer  sourcel.id,  source2_id,  source3_id,  source4_id 
integer  source.vp.set.source.geo 
integer  get.field, length, temp.il 
integer  i.rank 

integer  source.temp.id,  dest.temp.id 


destl.id  *  cmf_get_field_id(de8tl) 
de8t2_id  *  cmf.get.f ield_id(dest2) 
dest3_id  ■  cmf.get.f ield_id(dest3) 
de8t4_id  ■  cmf.get.f ield_id(dest4) 

index. l.id  ■  cmf .get _field_id( index. 1) 
sourcel.id  «  cmf_get_field_id(sourcel) 
source2_id  ■  cmf.get.f ield_id(source2) 
source3_id  =  cmf.get.f ield_id(source3) 
8ource4_id  *  cmf_get_field_id(source4) 


if  (destl.id  .eq.  0)  then 
print  *, 

♦’Error,  the  destl  argument  to  gather4_ld  is  not  on  the  CM’ 
stop 
endif 


if  (dest2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest2  argument  to  gather4_ld  is  not  on  the  CM’ 
8tOp 
endif 
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if  (dest3_id  .  eq.  0)  then 
print  *, 

+» Error,  the  dest3  argument  to  gather4_ld  is  not  on  the  CM* 
stop 
endif 

if  (dest4_id  .eq.  0)  then 
print  *, 

+’ Error,  the  dest4  argument  to  gather4_id  is  not  on  the  CM’ 
stop 
endif 


if  (index.l.id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_l  argument  to  gather4_ld  is  not  on  the  CM’ 
stop 
endif 

if  (sourcel.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source 1  argument  to  gather4_ld  is  not  on  the  CM’ 
stop 
endif 

if  (source2_id  .eq.  0)  then 
print  ♦, 

♦’Error,  the  source2  argument  to  gather4_ld  is  not  on  the  CM’ 
stop 
endif 

if  (souxce3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  souxce3  argument  to  gather4_ld  is  not  on  the  CM* 
8t0p 
endif 

if  (source4_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source4  argument  to  gather4_ld  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  =  cof _get_vp_set_id(destl) 
dest.geo  *  cm_vp_set_geometry(dest_vp_set) 

source.vp.set  *  cmf _get_vp_set_id(sourcel) 

Bource.geo  *  cm_vp_8et_geometry(source_vp_set) 
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call  cm_set_vp_set(source_vp_set) 
source.temp.id  =  CM.allocate.stack.f ield(4*32) 
call  CM_u_move_lL(source_temp_id,  sourcel.id,  32) 
call  CM_u_move_lL(source_temp_id  +  32,  source2_id,  32) 
call  CM_u_move.lL (source.temp.id  ♦  64,  source3_id,  32) 
call  CM_u_move_lL(source_temp_id  +  96,  source4_id,  32) 

call  cm_set_vp_set(dest_vp_set) 

get.field  «  cm_allocate_stack_field(32) 
temp  *  cm_allocate_stack_f ield(32) 
il  *  cm.allocate.stack.f ield(32) 
call  cm.set.contextO 

dest_temp_id  *  CM_allocate_stack_f ield(4*32) 

c  select  context  for  destination 

call  cm_my_news_coordinate_ 11 (temp ,0,32) 
call  cm_u_eq_constant_ll(temp,0,32) 
call  cm_logand_context_vith_test() 

rank  *  cm_geometry_rank(dest_geo) 
do  i*l, rank-1 

length  *  cmf_get_axi8_extent(destl,i-l) 
call  CM_my_news_coordinate_lL(temp , i ,32) 
call  CM_u_lt .constant. 1L (temp , length , 32) 
call  CM.logand.context.with.test ( ) 
enddo 

call 
call 
call 

+ 

call 
call 
call 
call 
call 

call 
call 
call 
call 
call 
return 
end 


cm_u_move_zero_always_ 11 (get.f ield , 32) 
cm_u_subtract_constant.3_ll(il,index_l_id,l,32) 
cm.deposit.news.coordinate.lKsource.geo,  get.f  ield,  1 , 

il,32) 

cm_get.il (dest.temp. id , get.f ield , source.temp.id , 4*32) 
CM_u_move_lL(destl_id,  dest.temp.id,  32) 
CM_u_move_lL(dest2_id,  dest.temp.id  +  32,  32) 
CM_u_move_lL(dest3_id,  dest.temp.id  +  64,  32) 
CM_u_move_lL(dest4_id,  dest.temp.id  ♦  96,  32) 

cm_deallocate_stack_through(dest_temp_id) 

CMF_set_is_modified(destl,MODIF) 

CMF_set_is_modified(dest2,M0DIF) 

CMF.set.is.modified(dest3,H0DIF) 

CHF.set.is.modif ied(dest4,M0DIF) 
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subroutine  gather l_2d(dest, index. l,index_2, source) 

include  ’/usr/include/cm/paris-conf iguration-fort.h’ 
include  * /usr/include/cm/CMF_def s .h* 

c  compute  dest  *  source ( index. 1 ,index_2) 
c  gets  source  (2-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 

c  dest  :  real  destination  field;  n-dimensional 

c  index.l  :  integer  field  ;  first  index  of  source  array 

c  index_2  :  integer  field  ;  second  index  of  source  array 

c  source  :  real  source  field;  2-dimensional 

integer  dest , dest. id , dest.vp.set , dest.geo 
integer  index.l, index.l.id 
integer  index_2,index_2_id 

integer  source , source. id , source.vp.set , source.geo 
integer  get.f ield , length , temp , il , i2 
integer  i.rank 

dest. id  ■  cmf_get_field_id(dest) 
index.l.id  ■  cmf.get.f ield.id(index.l) 
index .2. id  *  cmf_get.field_id(index_2) 
source.id  ■  cmf_get_field_id(source) 

if  (dest.id  .eq.  0)  then 
print  *, 

•♦•’Error,  the  dest  argument  to  gatberl_2d  iB  not  on  the  CM’ 
stop 
endif 

if  (index.l.id  .eq.  0)  then 
print  *, 

■♦’Error,  the  index.l  argument  to  gather l_2d  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_2  argument  to  gatherl_2d  is  not  on  the  CM’ 
stop 
endif 

if  (source.id  .eq.  0)  then, 
print  *, 

♦’Error,  the  source  argument  to  gather l_2d  is  not  on  the  CM’ 
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stop 

endif 

dest_vp_set  *  cmf _get_vp_set_id(dest) 
dest.geo  *  cm.vp.set.geometry (dest.vp.set) 

source.vp.set  =  cmf _get_vp_set_id(source) 
source.geo  *  cm_vp_set_geometry(source_vp_8et) 

call  cm.set.vp.set (dest.vp.set) 

get.field  =  cm.allocate.stack.f ield(32) 
temp  *  cm.allocate.stack.f ield(32) 

11  *  cm_allocate_stack_f ield(32) 

12  =  cm_allo<~ate_stack_f  ield(32) 

select  context  for  destination 
call  cm_set_context() 

call  cm.my.nevs. coordinate. 11 (temp , 0 , 32) 
call  cm_u_eq_constant.il (temp, 0,32) 
call  cm.logand.context.with.test ( ) 

rank  *  cm_geometry_rank(dest_geo) 
do  i«l, rank-1 

length  *  cmf_get_axi8_extent(dast,i-l) 
call  CM_my_new8_coordinate_lL(temp,i,32) 
call  CM.u.lt.constant. 1L (temp , length , 32) 
call  CM_logand_context_with_test() 
erddo 

call  cm_u_move_zero_alvays.il (get.f ield,32) 

call  cm_u_subtract_constant_3_ll(il , index_l_id, 1 ,32) 

call  cm_u_subtract_constant_3_ll(i2 , index_2_id, 1 ,32) 

call  cm_deposit_nevs_coordinate.il (source.geo,  get.field.l, 

+  il ,32) 

call  cm_deposit_news_coordinate_ll(source_geo ,  get_field,2, 
+  i2,32) 

call  cm_get_ll(dest_id,get_field,8ource_id,32) 

call  cm_deallocate_stack_through(get_f ield) 
call  CMF_set_i8_modif ied(dest ,M0DIF) 
return 
end 


subroutine  gather2_2d(destl ,  dest2,  index.l,  index_2, 

sourcel,  source2) 
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include  ’/usr/include/cm/paris-conf igur at ion-fort .h’ 
include  ’ /usr/ include/cm/ CMF.def s .h’ 

c  compute  destl  =  source 1( index. 1 , index_2) 
c  dest2  =  source2 ( index. 1 ,index_2) 

c 

c  gets  source  (2-dimensional)  for  dast  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 

c  destl  :  real  destination  field;  n-dimensional 

c  dest2  :  real  destination  field;  n-dimensional 

c  index.l  :  integer  field  ;  first  index  of  source  array 

c  index_2  :  integer  field  ;  second  index  of  source  array 

c  sourcel  :  real  source  field;  2-dimensional 

c  source2  :  real  source  field;  2-dimensional 

integer  destl,  dest2 
integer  sourcel,  source2 
integer  destl.id,  dest2_id 
integer  dest.vp.set .dest.geo 
integer  index.l, index.l .id 
integer  index_2,index_2_id 
integer  sourcel.id,  source2.id 
integer  source.vp.set.source.geo 
integer  get.f ield , length , temp , i 1 , i2 
integer  i.rank 

integer  source.temp.id,  dest.temp.id 

destl.id  ■  cmf .get.f ield.id(destl) 
dest2_id  =  cmf .get.f ield_id(dest2) 

index.l.id  =  cmf .get.f ield.id(index.l) 
index_2_id  =  cmf .get.f ield_id(index_2) 
sourcel.id  =  cmf.get.f ield.id(sourcel) 
source2_id  *  cmf .get.f ield_id(source2) 

if  (destl.id  .eq.  0)  then 
print  *, 

+’ Error,  the  destl  argument  to  gather2_2d  is  not  on  the  CM’ 
stop 
endif 

if  (dest2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest2  argument  to  gather2_2d  is  not  on  the  CM’ 
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stop 

endif 

if  (index.l.id  .eq.  0)  then 
print  *, 

+’ Error,  the  index. 1  argument  to  gather2_2d  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

♦  ’ Error,  the  index_2  argument  to  gather2_2d  is  not  on  the  CM’ 
stop 
endif 

if  (sourcel.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source 1  argument  to  gather2_2d  is  not  on  the  CM’ 
stop 
endif 

if  (80urce2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source2  argument  to  gather2_2d  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  *  cmf _get_vp_set_id(destl) 
dest.geo  *  cm.vp.set.geometry (dest.vp.set) 

80urce_vp_8et  *=  cmf _get_vp_set_id(sourcel) 
source.geo  =  cm.vp.set.geometry (source.vp.set) 
call  cm_8et_vp_8et (source.vp.set) 
source.temp.id  ■  CM.allocate.stack.f ield(2*32) 
call  CM_u_move_lL(source_temp_id,  sourcel.id,  32) 
call  CM_u_move_lL(source_temp_id  +  32,  soutce2_id,  32) 

call  cm_set_vp_8et (dest.vp.set) 

get.field  »  cm.allocate.stack.f ield(32) 
temp  *  cm.allocate.stack.f ield(32) 

11  *  cm_allocate_stack.field(32) 

12  ■  cm.allocate.stack.f ield(32) 
call  cm.set.contextO 

dest.temp.id  =  CM_allocate_stack_field(2*32) 
c  select  context  for  destination 
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call  cm.my.news. coordinate. 11 (temp ,0,32) 
call  cm.u.eq.constant. 11 (temp ,0,32) 
call  cm.logand.context.with.testO 

rank  =  cm_geometry_rank(dest_geo) 
do  i=l, rank-1 

length  =  cmf _get_aucis_extent(destl,i-l) 
call  CM_my_nevs_coordinate_lL(temp , i ,32) 
call  CM_u_lt_constant_ 1L (temp .length , 32) 
call  CM.logand.context.with.testQ 
enddo 

call  cm_u_move_zero_alvays_ll(get_f ield,32) 
call  cm_u_subtract_constant_3_ll(il , index_l_id, 1 ,32) 
call  cm_u_subtract_constant_3_ll(i2 ,index_2_id, 1,32) 
call  cm_deposit_nevs_coordinate_ll(source_geo,  get.field.l, 
+  il,32) 

call  cm.deposit.news.coordinate.lKsource.geo,  get_field,2, 
+  12,32) 

cadi  cm.get. 11 (dest.temp.id , get.f ield , source.temp.id , 2*32) 
call  CM_u.move_lL(destl_id,  dest.temp.id,  32) 
call  CM_u_move_lL(deat2_id,  dest.temp.id  +  32,  32) 

call  cm_deallocate_stack_through(dest_temp_id) 

call  CMF_set_is_modif ied(destl ,M0DIF) 

call  CMF_set_is_modified(dest2,M0DIF) 

return 

end 


subroutine  gather3_2d(destl ,  dest2,  dest3,  index_l,  index_2, 
+  8ourcel,  source2,  source3) 


include  ’/usr/include/cm/paris-conf igurat ion-fort .h’ 
include  ’ /uar/include/cm/CMF_def a . h ' 


compute  deat  ■  source ( index. 1 ,index_2) 

gets  source  (2-dimensional)  for  deat  (n-dimensionad) 

the  dest  and  index  fields  must  be  in  the  same  vp  set 

parameters 

destl  :  real  destination  field;  n-dimensional 

dest2  :  real  destination  field;  n-dimensionad 

dest3  :  real  destination  field;  n-dimensional 

index. 1  :  integer  field  ;  first  index  of  source  array 

index_2  :  integer  field  ;  second  index  of  source  array 
sourcel  :  real  source  field;  2-dimensional 

source2  :  real  source  field;  2-dimensional 
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c  source3  :  real  source  field;  2-dimensional 

integer  destl,  deat2,  dest3 
integer  sourcel,  source2,  source3 
integer  destl.id,  dest2_id,  dest3_id 
integer  dest_vp_set ,dest_geo 
integer  index.l, index_l_id 
integer  index_2,index_2_id 
integer  sourcel.id,  source2_id,  source3_id 
integer  source_vp_set,source_geo 
integer  get_f ield , length , temp , i 1 , i2 
integer  i.rank 

integer  source_temp_id,  dest.temp.id 

destl_id  *  cmf _get_f ield_id(destl) 
dest2.id  *  cmf_get_f ield_id(dest2) 
dest3_id  ■  cmf _get_f ield_id(dest3) 

index_l_id  *  cmf.get.f ield_id(index_l) 
index_2_id  ■  cmf _get_f ield_id(index_2) 
sourcel.id  *  cmf_get_field_id(sourcel) 
source2_id  *  cmf_get_f ield_id(source2) 
source3_id  =  cmf_get_field_id(source3) 

if  (destl.id  .eq.  0)  then 
print  *, 

+’ Error,  the  destl  argument  to  gather3_2d  is  not  on  the  CM* 
stop 
endif 

if  (dest2_id  .eq.  0)  then 
print  *, 

♦’ Error,  the  dest2  argument  to  gather3_2d  is  not  on  the  CM’ 
stop 
endif 

if  (dest3_id  .eq.  0)  then 
print  *, 

+’Error,  the  dest3  argument  to  gather3_2d  is  not  on  the  CM* 
stop 
endif 

if  (index_l_id  .eq.  0)  then 
print  *, 

+’ Error,  the  index. 1  argument  to  gather3_2d  is  not  on  the  CM’ 
stop 
endif 
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if  (index_2_id  .eq.  0)  then 
print  *, 

♦  ’ Error,  the  index_2  argument  to  gather3_2d  is  not  on  the  CM* 
stop 
endif 

if  (sourcel.id  .eq.  0)  then 
print  *, 

♦’Error,  the  sourcel  argument  to  gather3_2d  is  not  on  the  CM’ 
stop 
endif 

if  (source2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source2  argument  to  gather3_2d  is  not  on  the  CM’ 
stop 
endif 

if  (source3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source3  argument  to  gather3_2d  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  =  cmf_get.vp.set_id(destl) 
dest.geo  *  cm. vp.set .geometry (dest.vp.set) 

source_vp_8et  =  cmf _get_vp_set_id(sourcel) 

source.geo  *  cm_vp_set_geometry(source_vp_set) 

call  cm_set_vp_set(source_vp_set) 

source. temp. id  *  CM.allocate.stack.f ield(3*32) 

call  CM_u_move_lL(source_temp_id,  sourcel.id,  32) 

call  CM_u_move_lL(source_temp_id  ♦  32,  source2_id,  32) 

call  CM_u_move_lL(80urce_temp_id  ♦  64,  source3_id,  32) 

cadi  cm_8et_vp_set(dest_vp_set) 

get.field  ■  cm.allocate.stack.f ield(32) 
temp  =  cm.allocate.stack.f ield(32) 

11  *  cm.allocate.stack.f ield(32) 

12  =  cm.allocate.stack.f ield(32) 
call  cm.set.contextO 

dest.temp.id  ■  CM.allocate.stack.f ield(3*32) 
c  select  context  for  destination 

call  cm.my.news. coordinate. 11 (temp ,0,32) 
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call  cm_u_eq_constant_ 11 (temp ,0,32) 
call  cm_logand_context_vith_test() 

rank  =  cm_geometry_rank(dc2t_geo) 
do  i=l ,rank-l 

length  =  cmf_get_axis_extent(deatl,i-l) 
call  CH_my_news_coordinate_lL(temp,i,32) 
call  CM_u_lt_constant_ lL(temp , length , 32) 
call  CM_logand_context_uith_test() 
enddo 

call  cm_u_move_zero_always_ll(get_field,32) 
call  cm_u_subtract_constant>3_ll(il,index_i_id,l,32) 
call  cm_u_subtract_constant^3_ 11 (i2 , index_2_id ,1,32) 
call  cm_deposit_news_coordinate_ll(source_geo,  get_field,l, 

11 .32) 

call  cm_deposit_news_coordinate_ll(source_geo,  get_field,2, 

12.32) 

call  cm_get_ll (dest_temp_id , get_f ield, source_temp_id , 3*32) 
call  CM_u_move_lL(destl_id,  dest_temp_id,  32) 
call  CM_u_move_lL(dest2_id,  dest_temp_id  +  32,  32) 
call  CM_u_move_lL(dest3_id,  dest_temp_id  +  64,  32) 

call  cm_deallocate_stack_through(dest_temp_id) 

call  CMF_set_is_modif ied(destl ,M0DIF) 

call  CMF_set_is_modified(dest2,M0DIF) 

call  CMF_8et_is_modif ied(dest3 ,M0DIF) 

retirm 

end 


subroutine  gather4_2d(destl ,  dest2,  dest3,  dest4,  index.l, 
♦  index_2,  sourcel,  source2,  source3, 

+  source4) 

include  ’/usr/include/cm/paris-conf igurat ion-fort .h’ 
include  ’/usr/include/cm/CMF.defs .h’ 

c  compute  dest  *  source(index_l,index_2) 
c  gets  source  (2-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 

c  destl  :  real  destination  field;  n-dimensional 

c  dest2  :  real  destination  field;  n-dimensional 

c  dest3  :  real  destination  field;  n-dimensional 

c  dest4  :  real  destination  field;  n-dimensional 

c  index.l  :  integer  field  ;  first  index  of  source  array 
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c  index. 2 
c  sourcel 
c  source2 
c  source3 
c  source4 


:  integer  field  ;  second  index  of  source  array 
:  real  source  field;  2-dimensional 
:  real  source  field;  2-dimensional 
:  real  source  field;  2-dimensional 
:  real  source  field;  2-dimensional 


integer  destl,  dest2,  dest3,  dest4 
integer  sourcel,  source2,  source3,  source4 
integer  destl.id,  dest2_id,  dest3_id,  dest4_id 
integer  dest_vp_set,dest_geo 
integer  index_l,index_l_id 
integer  index_2,index_2_id 

integer  sourcel.id,  source2_id,  source3_id,  source4_id 
integer  source.vp.set.source.geo 
integer  get.f ield , length , temp , i 1 , i2 
integer  i .rani 

integer  source.temp.id,  dest.temp.id 


destl.id 

dest2_id 

dest3_id 

dest4_id 


cmf  .get.f ield_id(de8tl) 
cmf.get.f ield_id(dest2) 
cmf .get.f ield. id(dest3) 
cmf  .get.f  ield_id(dest4) 


index. 1. id 
index_2_id 
sourcel.id 
8ource2_id 
source3_id 
source4_id 


cmf .get.f ield.id(index.l) 
cmf  .get.f ield_id(index_2) 
cmf.get.f ield. id ( source 1 ) 
cmf .get.f ield_id(source2) 
cmf .get.f ield_id(80urce3) 
cmf .get.f ield_id(source4) 


if  (destl.id  . eq.  0)  then 
print  *, 

♦'Error,  the  destl  argument  to  gather4_2d  is  not  on  the  CM’ 
stop 
endif 


if  (dest2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest2  argument  to  gather4_2d  is  not  on  the  CM’ 
stop 
endif 


if  (dest3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest3  argument  to  gather4_2d  is  not  on  the  CM’ 
stop 
endif 
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if  (dest4_id  .eq.  0)  then 
print  *, 

♦  ’ Error,  the  dest4  argument  to  gather4_2d  is  not  on  the  CM’ 
stop 
endif 


if  (index_l_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index. 1  argument  to  gather4_2d  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_2  argument  to  gather4_2d  is  not  on  the  CM’ 
stop 
endif 

if  (sourcel.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source 1  argument  to  gather4_2d  is  not  on  the  CM’ 
stop 
endif 

if  (source2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source2  argument  to  gather4_2d  is  not  on  the  CM’ 
stop 
endif 

if  (source3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source3  argument  to  gather4_2d  is  not  on  the  CM’ 
stop 
endif 

if  (source4_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source4  argument  to  gather4_2d  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  =  cmf _get_vp_set_id(destl) 
dest.geo  *  cm_vp_set_geometry(dest_vp_set) 

source.vp.set  *  cmf _get_vp_set_id(sourcel) 
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source_geo  =  cm_vp_set_geometry(source_vp_set) 
call  cm_set_vp_set(source_vp_set) 
source.temp.id  =  CM.allocate.stack.f ield(4*32) 
call  CM_u_move_lL(source_temp_id,  sourcel.id,  32) 
call  CM_u_move_lL(source_temp_id  ♦  32,  source2_id,  32) 
call  CM_u_move_lL(source_temp_id  ♦  64,  source3_id,  32) 
call  CM_u_move_lL(source_temp_id  +  96,  source4_id,  32) 

call  cm_set_vp_set(dest_vp_set) 

get.field  *  cm.allocate.stack.f ield(32) 
temp  *  cm.allocate.stack.f ield(32) 

11  *  cm.allocate.stack.f ield(32) 

12  *  cm_allocate_stack_field(32) 
call  cm_set_context() 

dest_temp_id  *  CM.allocate.stack.f ield(4*32) 

c  select  context  for  destination 

call  cm_my_news_coordinate_ll(temp,0,32) 
caill  cm_u_eq_const ant_  11  (temp  ,0,32) 
call  cm_logand_context_with_test() 

rank  *  cm_geometry_rank(dest_geo) 
do  i*l, rank-1 

length  *  cmf_get_axis_extent(destl,i-l) 
call  CM_my_new8_coordinate_lL(temp , i ,32) 
call  CM_u_lt .constant. 1L ( temp , length , 32) 
call  CM.logand.context.with.testO 
enddo 

call  cm.u.move.zero.always.ll (get .field , 32) 
call  cm_u_8ubtract_constant _3_ 11 ( i 1 , index. l.id , 1 , 32) 
call  cm_u_subtract_constant_3_ll(i2, index_2_id, 1,32) 
call  cm_deposit_nev8_coordinate_ll(source_geo,  get.field.l, 
+  il ,32) 

call  cm_deposit_news_coordinate_ll(source_geo,  get_field,2, 
♦  i2,32) 

call  cm_get.il (dest.temp.id , get .field , source.temp.id ,4*32) 
call  CM_u_move_lL(destl_id,  dest.temp.id,  32) 
call  CM_u_move_lL(dest2_id,  dest.temp.id  +  32,  32) 
call  CM_u_move_lL(dest3_id,  dest.temp.id  ♦  64,  32) 
call  CM_u_move_lL(dest4_id,  dest.temp.id  ♦  96,  32) 

call  cm_deallocate_stack_through(dest_temp_id) 
call  CMF_8et_is_modified(destl,M0DIF) 
call  CMF.set.is.modif ied(dest2,M0DIF) 
call  CMF.set.is.modif ied(dest3,M0DIF) 
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call  CMF_set_is_niodified(dest4,M0DIF) 

return 

end 


subroutine  gather l_3d(dest , index.l , index_2 , index_3 , source) 

include  ’/usr/include/cm/paris-conf iguration-fort .h’ 
include  ’ /usr/include/cm/CMF_def s .h’ 

c  compute  dest  =  source (index. l,index_2,index_3) 
c  gets  source  (3-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 

c  dest  :  real  destination  field;  n- dimensional 

c  index.l  :  integer  field  ;  first  index  of  source  array 

c  index_2  :  integer  field  ;  second  index  of  source  array 

c  index_3  :  integer  field  ;  third  index  of  source  array 

c  source  :  real  source  field;  3-dimensional 

integer  dest , dest. id , dest.vp.set , dest.geo 
integer  index.l, index.l .id 
integer  index_2,index_2_id 
integer  index_3, index. 3_ id 

integer  source , source.id , source. vp.set , source.geo 
integer  get _f ield , length , temp , i 1 , i2 , i3 
integer  i.rank 

dest.id  *  cmf.get.f ield.id(dest) 
index.l.id  *  cmf_get_field_id(index_l) 
index_2_id  *  cmf .get.f ield_id(index_2) 
index_3_id  *  cmf_get_field_id(index_3) 
source.id  =  cmf.get.f ield.id(source) 

if  (dest.id  .eq.  0)  then 
print  *, 

+’ Error,  the  dest  argument  to  gather l_3d  is  not  on  the  CM' 
stop 
endif 

if  (index.l.id  .eq.  0)  then 
print  *, 

♦'Error,  the  index.l  argument  to  gatherl_3d  is  not  on  the  CM’ 
8t0p 
endif 

if  (index_2_id  .eq.  0)  then 
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print  *, 

♦’Error,  the  index_2  argument  to  gatherl_3d  is  not  on  the  CM’ 
stop 
endif 

if  (index_3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_3  argument  to  gatherl_3d  is  not  on  the  CM’ 
stop 
endif 

if  (source.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source  argument  to  gatherl_3d  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  =  cmf_get_vp_set_id(dest) 
dest.geo  *  cm. vp.set .geometry (dest.vp.set) 

source_vp_set  *  cmf _get_vp_set_id(source) 
source.geo  *  cm_vp_set_geometry(source_ vp.set) 

call  cm_set_vp_set(dest_vp_set) 

get.field  «  cm.allocate_stack_field(32) 
temp  «  cm_allocate_8tack_field(32) 

11  ■  cm_allocate_8tack_field(32) 

12  ■  cm_allocate_stack_f ield(32) 

13  *  cm_allocate_stack_field(32) 

c  select  context  for  destination 

call  cm_set_context() 
call  cm_my_news_coordinate_ 11 (temp, 0,32) 
call  cm_u_eq_constant_ll(temp,0,32) 
call  cm_logand_context_vith_testO 

rank  «  cm_geometry_rank(de8t_geo) 
do  i«l, rank-1 

length  ■  cmf _get_axis_extent(dest,i-l) 
call  CM_my_ness_coordinate_lL(temp,i,32) 
call  CM_u.lt .const ant. 1L (temp , length , 32) 
call  CM.logand.context.with.testO 
enddo 

call  cm.u.move.zero.always. 11 (get.f ield , 32) 

call  cm_u_subtract.constant_3_ll(il , index. l.id, 1,32) 
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call  cm_u_subtract_constant_3_ll(i2,index_2_id, 1,32) 
call  cm_u_subtract_constant_3_ll(i3,index_3_id, 1 ,32) 
call  cm_deposit_news_coordinate_ll(source_geo,  get_field,l, 
+  il ,32) 

call  cm_deposit_news_coordinate.il (source.geo,  get_field,2, 
+  i2,32) 

call  cm_deposit_nevs_coordinate.il (source.geo,  get_field,3, 
+  i3,32) 

call  cm_get_ll(dest_id,get_f ield, source. id, 32) 

call  cm_deallocate_stack_through(get_f ield) 
call  CMF_set_is_modif ied(dest ,M0DIF) 
return 
end 


subroutine  gather2_3d(destl,  dest2,  index_l,  index_2,  index_3, 
+  sourcel,  source2) 

include  '/usr/include/cm/paris-configuration-fort .h’ 
include  */usr/ include/cm/ CMF.defs .h’ 

c  compute  destl  ■  sourcel(index_l,index_2,index_3) 
c  dest2  «  8ourca2( index, 1 ,index_2,index_3) 

c 

c  gets  source  (3-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 

c  destl  :  real  destination  field;  n-dimensional 

c  dest2  :  real  destination  field;  n-dimensional 

c  index.l  :  integer  field  ;  first  index  of  source  array 

c  index_2  :  integer  field  ;  second  index  of  source  array 

c  index_3  :  integer  field  ;  third  index  of  source  array 

c  sourcel  :  real  source  field;  3-dimensional 

c  source2  :  real  source  field;  3-dimensional 

integer  destl,  dest2 

integer  sourcel,  source2 

integer  destl_id,  dest2_id 

integer  dest_vp_set,dest_geo 

integer  index _1, index. 1_ id 

integer  index_2,index_2_id 

integer  index_3,index_3_id 

integer  sourcel.id,  source2_id 

integer  source. vp_set,source_geo 

integer  get.f ield , length , temp , il , i2 , i3 

integer  i.rani 


78 


integer  source.temp.id,  dest_temp_id 

destl.id  *  cmf .get.f ield.id(destl) 
dest2_id  =  cmf _get_f ield_id(dest2) 

index_l_id  =  cmf .get.f ield.id(index.l) 
index_2_id  =  cmf_get_field_id(index_2) 
index_3_id  =  cmf .get.f ield_id(index_3) 
sourcel_id  =  cmf  _get_field_id(sourcei) 
source2_id  =  cmf .get.f ield_id(source2) 

if  (destl_id  .eq.  0)  then 
print  *, 

♦’Error,  the  destl  argument  to  gather2_3d  is  not  on  the  CM' 
stop 
endif 

if  (dest2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest2  argument  to  gather2_3d  is  not  on  the  CM’ 

8tOp 

endif 

if  (index.l.id  .eq.  0)  then 
print  *, 

♦’Error,  the  index. 1  argument  to  gather2_3d  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_2  argument  to  gather2_3d  is  not  on  the  CM’ 
stop 
endif 

if  (index_3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index.3  argument  to  gather2_3d  is  not  on  the  CM’ 
stop 
endif 

if  (sourcel.id  .eq.  0)  then 
print  *, 

♦  ’Error,  the  source  1  argument  to  gather2_3d  is  not  on  the  CM’ 
8t0p 
endif 
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if  (source2_id  .eq.  0)  then 
print  *, 

+’ Error,  the  source2  argument  to  gather2_3d  is  not  on  the  CM’ 
stop 
endif 

dest_vp_set  =  cmf _get_vp_set_id(destl) 
dest.geo  =  cm_vp_set_geometry(dest_vp_set) 

source_vp_set  =  cmf _get_vp_set_id(sourcel) 
source.geo  =  cm_vp_set_geometry(source_vp_set) 
call  cm_set_vp_set(source_vp_set) 
source_temp_id  ■  CM.allocate.stack.f ield(2*32) 
call  CM_u_move_lL(source_temp_id,  sourcel.id,  32) 
call  CM_u_move_lL(source_temp_id  +  32,  source2_id,  32) 

call  cm_set_vp_set(dest_vp_set) 

get.field  *  cm_allocate_stack_field(32) 
temp  =  cm.allocate.stack.f ield(32) 

11  *  cm.allocate.stack.f ield(32) 

12  *  cm_allocate_stack_f ield(32) 

13  *  cm.allocate.stack.f ield(32) 
call  cm.set.contextO 

dest.temp.id  *  CM.allocate.stack.f ield(2*32) 

c  select  context  for  destination 

call  cm_my_news_coordinate_ 11 (temp, 0,32) 
call  cm_u_eq_constant_ 11 (temp ,0,32) 
call  cm.logand.context.with.testO 

rank  *  cm_geometry_rank(dest_geo) 
do  i*l, rank-1 

length  *  cmf _get_axis_extent(destl ,i-l) 
call  CM_my_news_coordinate_lL(temp , i ,32) 
call  CM_u_lt_con8tant.lL (temp, length, 32) 
call  CM.logand.context.with.testQ 
enddo 

call  cm.u.move.zero.alvays. 11 (get _f ield , 32) 
call  cm_u_subtract .const ant _3_ 11 ( i 1 , index. 1_ id , 1 , 32) 
call  cm_u_8ubtract_con8tant_3_ll(i2 , index_2_id, 1 ,32) 
call  cm_u_8ubtract_constant_3_ll(i3 ,index_3_id, 1,32) 
call  cm_deposit_news_coordinate_ll(source_geo,  get_field,l, 

♦  il ,32) 

call  cm_deposit_nevs_coordinate_ll(source_geo,  get_field,2, 

♦  i2 ,32) 
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call  cm_deposit_news_coordinate_ll(source_geo ,  get_field,3, 
+  i.3,32) 

call  cm.get .11 (dest .temp.id, get _field,source_temp_id, 2*32) 
call  CM_u_move_lL(destl_id,  dest.temp.id,  32) 
call  CM_u_move_lL(dest2_id,  dest_temp_id  +  32,  32) 

call  cm_deallocate_stack_through(dest_temp_id) 

call  CMF_set_is_modified(destl .MODIF) 

call  CMF_set_is_modif ied(dest2 , MODIF) 

return 

end 


subroutine  gather3_3d( destl,  dest2,  dest3,  index. 1,  index_2, 
+  index.3,  sourcel,  source2,  source3) 

include  ’/usr/include/cm/paris-conf iguration-fort .h’ 
include  ’ /usr/include/cm/CMF_def s .h ' 

c  compute  dest  =  source ( index. 1 ,index_2,index_3) 
c  gets  source  (3-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 

c  destl  ;  real  destination  field;  n-dimensional 

c  dest2  :  real  destination  field;  n-dimensional 

c  dest3  :  real  destination  field;  n-dimensional 

c  index.l  ;  integer  field  ;  first  index  of  source  array 

c  index_2  :  integer  field  ;  second  index  of  source  array 

c  index_3  :  integer  field  ;  third  index  of  source  array 

c  sourcel  :  real  source  field;  3-dimensional 

c  source2  :  real  source  field;  3-dimensional 

c  source3  :  real  source  field;  3-dimensional 

integer  destl,  dest2,  dest3 

integer  sourcel,  source2,  source3 

integer  destl.id,  dest2_id,  dest3_id 

integer  dest.vp.set.dest.geo 

integer  index.l , index.l. id 

integer  index.2,index_2_id 

integer  index_3,index_3_id 

integer  sourcel.id,  source2_id,  source3_id 

integer  source.vp.set.source.geo 

integer  get _f ield , length , temp , i 1 , i2 , i3 

integer  i.rank 

integer  source.temp.id,  dest.temp.id 
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destl.id  =  cmf _get_f ield_id(destl) 
dest2_id  =  cmf _get_f ield_id(dest2) 
dest3_id  =  cmf _get_f ield_id(dest3) 

index_l_id  =  cmf _get_f ield_id(index_l) 
index_2_id  =  cmf _get_f ield_id(index_2) 
index_3_id  =  cmf _get_f ield_id(index_3) 
sourcel.id  =  cmf  _get_f ield_id(sourcel) 
source2_id  =  cmf _get_f ield_id(source2) 
source3_id  =  cmf _get_f ield_id(source3) 

if  (destl.id  .eq.  0)  then 
print  *, 

♦’Error,  the  destl  argument  to  gather3_3d  is  not  on  the  CM’ 
stop 
endif 

if  (dest2_id  .eq.  0)  then 
print  * , 

+’ Error,  the  dest2  argument  to  gather3_3d  is  not  on  the  CM’ 

8tOp 

endif 

if  (dest3_id  .eq.  0)  then 
print  *, 

+’ Error,  the  dest3  argument  to  gather3_3d  is  not  on  che  CM’ 
stop 
endif 

if  (index_l_id  .eq.  0)  then 
print  *, 

+  ’ Error,  the  index. 1  argument  to  gather3_3d  iB  not  on  the  CM’ 
8  top 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

+  ’ Error,  the  index_2  argument  to  gather3_3d  is  not  on  the  CM’ 
8  top 
endif 

if  (index_3_id  .eq.  0)  then 
print  * , 

♦’Error,  the  index_3  argument  to  gather3_3d  is  not  on  the  CM’ 
stop 
endif 

if  (sourcel.id  .eq.  0)  then 
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print  * , 

+’Error,  the  sourcel  argument  to  gather3_3d  is  not  on  the  CM’ 
stop 
endif 

if  (sourc62_id  .eq.  0)  then 
print  *, 

+ ’Error,  the  source2  argument  to  gather3_3d  is  not  on  the  CM’ 
stop 
endif 

if  (source3_id  .eq.  0)  then 
print  *, 

+’ Error,  the  source3  argument  to  gather3_3d  is  not  on  the  CM* 
stop 
endif 

dest.vp.set  =  cmf _get_vp_8et_id(destl) 
dest_geo  *  cm.vp.set .geometry (dest.vp.set) 

source.vp.set  =  cmf _get_vp_set_id(aourcel) 
source.geo  «  cm_vp_set_geometry(source_vp_set) 
call  cm_set_vp_set(source_vp_set) 
source_temp_id  *  CM.allocate.stack.f ield(3*32) 
call  CM_u_move_lL(source_temp_id,  sourcel.id,  32) 
call  CM_u.move_lL(source_temp_id  ♦  32,  source2_id,  32) 
call  CM_u_move_lL(source_temp_id  ♦  64,  source3_id,  32) 

call  cm_set_vp_set(dest_vp_set) 

get.field  ■  cm.allocate.stack.f ield(32) 
temp  *  cm.allocate.stack.f ield(32) 

11  *  cm_allocate_stack_f ield(32) 

12  *  cm_allocate_stack_f ield(32) 

13  *  cm_allocate_8tack_f ield(32) 
call  cm_set_context() 

dest_temp_id  *  CM.allocate.stack.f ield(3*32) 

c  select  context  for  destination 

call  cm_my .news .coordinate. 11 (temp ,0,32) 
call  cm.u.eq. const ant. 11 (temp ,0,32) 
call  cm.logand.context.with.testO 

rank  *  cm_geometry_rank(dest_geo) 
do  i=l, rank-1 

length  =  cmf _get_axis_extent(destl , i-1) 
call  CM.my .news. coordinate. lL(temp , i ,32) 
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call  CM_u_lt_constant_lL( temp, length, 32) 
call  CM_logand_context_vith_test() 
enddo 

call  cm_u_move_zero_alvays.il (get.f ield,32) 
call  cm_u_subtract_constant_3_ll(il,index_l_id, 1,32) 
call  cm_u_subtract_constant_3_ 11 ( i2 , index_2_id ,1,32) 
call  an_u_subtract_constant_3_ll(i3 , index_3_id, 1,32) 
call  cm_deposit_nevs_coordinate_ll(source_geo,  get_field,l, 

11 .32) 

call  cm_deposit_news_coordinate_ll(Bource_geo,  get_field,2, 

1.2.32) 

call  cm_deposit_nevs_coordinate_ll(source_geo,  get_fieid,3, 

13 .32) 

cadi  cm_get_ 11 (dest.temp. id, get.f ield,source_temp_id, 3*32) 
call  CM_u_move_lL(destl_id,  dest.temp.id,  32) 
call  CM_u_move_lL(dest2_id,  dest.temp.id  ♦  32,  32) 
call  CM_u_move_lL(dest3_id,  dest.temp.id  +  64,  32) 

call  cm_deallocate_stack_through(dest_temp_id) 

call  CMF.set.is.modif ied(destl ,M0DIF) 

call  CMF.set.is.modif ied(dpjt2 ,M0DIF) 

call  CMF_set_is_modif ied(dest3 .MODIF) 

return 

end 


subroutine  gather4_3d(destl ,  dest2,  deBt3,  dest4,  index_l, 
♦  index_2,  index_3,  sourcel,  source2, 

+  80urce3,  source4) 

include  ’ /usr/include/cm/patris-conf iguration-f ort .h’ 
include  ’/usr/include/cm/CMF.defs .h’ 

c  compute  deat  *  source(index_l,index_2,index_3) 
c  gets  source  (3-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 
c  destl 

c  dest2 

c  dest3 

c  dest4 

c  index. 1 

c  index. 2 

c  sourcel 

c  source2 

c  source3 


real  destination  field;  n-dimensional 
real  destination  field;  n-dimensional 
real  destination  field;  n-dimensional 
real  destination  field;  n-dimensionad 
integer  field  ;  first  index  of  source  array 
integer  field  ;  second  index  of  source  array 
real  source  field;  3-dimensional 
real  source  field;  3-dimensional 
real  source  field;  3-dimensional 
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source4 


:  real  source  field;  3-dimensional 


integer  destl,  dest2,  dest3,  dest4 

integer  sourcel,  source2,  source3,  source4 

integer  destl.id,  dest2_id,  dest3_id,  dest4_id 

integer  dest_vp_set ,dest_geo 

integer  index_l,index_l_id 

integer  index_2,index_2_id 

integer  index_3,index_3_id 

integer  sourcel.id,  source2_id,  source3_id,  source4_id 
integer  source_vp_set, source.geo 
integer  get_f ield , length , temp , i 1 , i2 , i3 
integer  i.rank 


integer  source_temp_id,  dest.temp.id 


destl_id 

dest2_id 

dest3_id 

dest4_id 


cmf _get_f ield_id(destl) 
cmf _get_f ield_id(dest2) 
cmf _get_f ield_id(dest3) 
cmf _get_f ield_id(dest4) 


index_l_id 

index_2_id 

index_3_id 

sourcel.id 

source2_id 

80urce3_id 

source4_id 


cmf _get _f ield.id ( index. 1 ) 
cmf_get_f ield_id(index_2) 
cmf_get_f ield_id(index_3) 
cmf_get_field_id(sourcel) 
cmf_get_field_id(source2) 
cmf_get_field_id(source3) 
cmf_get_field_id(source4) 


if  (destl.id  .eq.  0)  then 
print  *, 

♦’Error,  the  destl  argument  to  gather4_3d  is  not  on  the  CM’ 
stop 
end  if 


if  (dest2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest2  argument  to  gather4_3d  is  not  on  the  CM’ 
stop 
endif 

if  (dest3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest3  argument  to  gather4_3d  is  not  on  the  CM’ 
stop 
endif 


if  (dest4_id  .eq.  0)  then 
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print  *, 

+’Error,  the  dest4  argument  to  gather4_3d  is  not  on  the  CM’ 
stop 
endif 


if  (index_l_id  .eq.  0)  then 
print  *, 

+  ’ Error,  the  index. 1  argument  to  gather4_3d  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_2  argument  to  gather4_3d  is  not  on  the  CM’ 
stop 
endif 

if  (index_3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_3  argument  to  gather4_3d  is  not  on  the  CM’ 
stop 
endif 

if  (sourcel.id  .eq.  0)  then 
print  *, 

+’ Error,  the  sourcel  argument  to  gather4_3d  is  not  on  the  CM’ 
stop 
endif 

if  (80urce2_id  .eq.  0)  then 
print  * , 

♦’Error,  the  source2  argument  to  gather4_3d  is  not  on  the  CM’ 
stop 
endif 

if  (source3_id  ,eq.  0)  then 
print  *, 

♦’Error,  the  source3  argument  to  gather4_3d  is  not  on  the  CM’ 
stop 
endif 

if  (80urce4_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source4  argument  to  gather4_3d  is  not  on  the  CM’ 
stop 
endif 


86 


dest_vp_set  =  cmf _get_vp_set_id(destl) 
dest_geo  =  cm_vp_set_geometry (dest_vp_set) 

source_vp_set  =  cmf _get_vp_s9t_id(sourcel) 
source.geo  =  cm.vp.set.geometry (source.vp.set) 
call  cm.set.vp.set (source.vp.set) 
source_temp_id  *  CM.allocate.stack.f ield(4*32) 
call  CM_u_move_lL(source_temp_id,  sourcel.id,  32) 
call  CM_u_move_lL(source_temp_id  ♦  32,  source2_id,  32) 
call  CM_u_move_lL(source_temp_id  +  64,  source3_id,  32) 
call  CM_u_move_lL(source_temp_id  +  96,  source4_id,  32) 

call  cm_set_vp_set(dest_vp_set) 

get_field  ■  cm_allocate_stack_f ield(32) 
temp  *  cm_allocate_stack_f ield(32) 

11  *  cm_allocate_stack_f ield(32) 

12  *  cm_allocate_8tack_f ield(32) 

13  ■  cm.allocate.stack.f ield(32) 
call  cm.set.contextO 

dest_temp_id  *  CM.allocate.stack.f ield(4*32) 

c  select  context  for  destination 

call  cm_my_nevs_coordinate_ 11 (temp, 0,32) 
call  cm_u_eq_constant_ll(temp,0,32) 
call  cm_logand_context_with_test() 

rank  =  cm_geometry_rank(dest_geo) 
do  i«l, rank-1 

length  *  cmf_gtt_axis_extent(deatl,i-l) 
call  CH_my_news_coordinat e_ 1L (temp , i , 32 ) 
call  CM_u_lt_constant_lL(temp .length, 32) 
call  CM_logand_context_vith_test() 
enddo 

call  cm_u_move_zero_alvays_ll(get_f ield,32) 
call  cm_u_subtract_constant_3_ll(il ,index_l_id, 1,32) 
call  cm_u_8ubtract_constant_3_ll(i2 , index. 2_id, 1 ,32) 
call  cm_u_8ubtract_constant_3_ll(i3,index_3_id, 1,32) 
call  cm_deposit_news_coordinate.il (source.geo,  get_field,l, 

♦  il ,32) 

call  cm_doposit_news_coordinate_ll(source_geo,  get_field,2, 
+  i2,32) 

call  cm_deposit_news_coordinate_ll(8ource_geo,  get_field,3, 

♦  i3,32) 

call  cm_get_ll(dest_temp_id,get_f ield,source_temp_id,4*32) 
call  CM_u_move_lL(destl_id,  dest.temp.id,  32) 
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call  CM_u_move_lL(dest2_id,  dest_temp_id  +  32,  32) 
call  CM_u_move_lL(dest3_id,  dest_temp_id  +  64,  32) 
call  CM_u_move_iL(dest4_id,  dest.temp.id  ♦  96,  32) 

call  cm_deallocate_stack_through(dest_temp_id) 

call  CHF_set_is_modif ied(destl ,MDDIF) 

call  CMF_set_is_modified(dest2,M0DIF) 

call  CMF_set_is_modif ied(dest3 ,MODIF) 

call  CMF.set.is.modif ied(dest4 ,MODIF) 

return 

end 


subroutine  gather l_4d (dest , index. 1 , index_2 , index_3 , index_4 , 

source) 

include  ’/usr/include/cm/paris-conf igur at ion-fort .h’ 
include  ’/usr/include/cm/CMF.defs .h* 

c  compute  dest  ■  sour ce( index. l,index_2,index_3,index_4) 
c  gets  source  (4-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 

c 

c  parameters 

c  dest  :  read  destination  field;  n-dimensional 

c  index. 1  :  integer  field  ;  first  index  of  source  array 

c  index_2  ;  integer  field  ;  second  index  of  source  array 

c  index_3  :  integer  field  ;  third  index  of  source  array 

c  index_4  :  integer  field  ;  fourth  index  of  source  array 

c  source  :  real  source  field;  3-dimensional 

integer  dest , dest. id, dest. vp.set, dest _geo 
integer  index_l,index_l_id 
integer  index_2,index_2_id 
integer  index_3,index_3_id 
integer  index_4,index_4_id 

integer  source, source_id,source_vp_set .source.geo 
integer  get.field, length , temp ,il , i2,i3, i4 
integer  i.ranh 

dest.ii  *  cmf .get.f ield.id(dest) 
index.l.id  ■  cmf_get_field_id(index_l) 
index_2_id  *  cmf .get.f ield.id(index_2) 
index_3_id  *  cmf .get.f ield_id(index_3) 
index_4_id  =  cmf .get.f ield_id(index_4) 
source.id  *  cmf .get.f ield.id(source) 

if  (dest.id  .eq.  0)  then 
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print  *, 

+’ Error,  the  dest  argument  to  gather l_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index. 1_ id  .eq.  0)  then 
print  *, 

♦’Error,  the  index.l  argument  to  gatherl_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

+’Error,  the  index_2  argument  to  gatherl_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_3  argument  to  gatherl_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_4_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_4  argument  to  gatherl_4d  is  not  on  the  CM’ 
stop 
endif 

if  (source.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source  argument  to  gatherl_4d  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  *  cmf_get_vp_set_id(dest) 
dest.geo  *  cm_vp_set_geometry(dest_vp_set) 

source.vp.set  ■  cmf .get.vp.set.idCsource) 
source.geo  ■  cm_vp_set_geometry(source_vp_set) 

call  cm_8et_vp_8et(dest_vp_set) 

get.field  »  cm_allocate_stack_f ield(32) 
temp  ■  cm_allocate_stack_f ield(32) 

11  ■  cm_ allocate. stack. f ield(32) 

12  ■  cm.allocate.stack.f ield(32) 

13  *  cm.allocate.stack.f ield(32) 
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i.4  B  cm.allocate.stack.f ield(32) 


c  select  context  for  destination 


call  cm_set_context() 

call  cm.my.new s.coordinate. 11 (temp , 0 , 32) 
call  cm_u_eq_constant_ 11 (temp ,0,32) 
call  cm_logand_context_vith_test() 

rank  *  cm_geometry_rank(dest_geo) 
do  i*l,rank-l 

length  =  cmf_£at_axis_extent(dest,i-i) 
call  CM_my_nevs_coordinate.lL (temp , i ,32) 
call  CM_u_lt_constant_lL (temp, length, 32) 
call  CM.logand.context.with.testO 
enddo 


call 

call 

call 

call 

call 

call 

call 

call 

call 

call 


an_u_move_zero_always_ 11 (get.f ield,32) 
cm_u_subtract_con8tant_3_ 11 ( ii , index. l_id ,1,32) 
an_u.8ubtract_con8tant.3_ ll(i2 , index_2_id , 1,32) 
cm_u_8ubtract_constant_3_ll(i3 ,index_3_id, 1 ,32) 
cm.u.subtract .constant^S. 11 ( i4 , index_4_ id , 1 , 32) 
cm_deposit_news_coordinate.il (source.geo,  get.f ield,  1 , 

11 .32) 

cm_depo8it  _mws_coordinate.il  (source.geo ,  get.f  ield ,  2 , 

12.32) 

cm_depo8it_news_coordinate_ll (source.geo,  get.f ield, 3, 

13.32) 


cm_depo8it_new8_coordinate_ 11 (source.geo ,  get.f ield ,4 , 

i4,32) 

cm_get_ll(de8t_id, get.f ield, source. id, 32) 


call  cm_deallocate_8tack_through(get_f ield) 
call  CMF.set.is.modif ied(dest .MODIF) 
return 
end 


subroutine  gather2_4d(destl ,  dest2,  index. 1,  index_2,  index_3, 
♦  index.4,  sourcel,  source2) 

include  '/usr/include/cm/paris-configuration-fort.h' 
include  '/uBr/include/cm/CMF.defs .h* 

c  compute  destl  =  sourcel (index. l,index_2,index_3,index_4) 
c  dest2  *  80urce2(index_l,index_2,index_3,index_4) 

c 

c  gets  source  (4-dimensional)  for  dest  (n-dimensional) 
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c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 

c  destl  :  real  destination  field;  n- dimens ional 

c  de8t2  :  real  destination  field;  n-dimensional 

c  index.l  :  integer  field  ;  first  index  of  source  array 

c  index_2  :  integer  field  ;  second  index  of  source  array 

c  index_3  :  integer  field  ;  third  index  of  source  array 

c  index_4  :  integer  field  ;  fourth  index  of  source  array 

c  sourcel  :  real  source  field;  3-dimensional 

c  source2  :  real  source  field;  3-dimensional 

integer  destl,  dest2 

integer  sourcel,  source2 

integer  destl.id,  dest2_id 

integer  dest.vp.set ,dest_geo 

integer  index.l , index_l_id 

integer  index_2,index_2_id 

integer  index_3,index_3_id 

integer  index_4 , index_4_id 

integer  sourcel_id,  source2_id 

integer  source_vp_set,source_geo 

integer  get _f ield , length , temp , i 1 , i2 , i3 , i4 

integer  i.rank 

integer  source.temp.id,  dest_teop_id 

destl.id  *  cmf .get.f ield.id(destl) 
de8t2_id  «  cmf _get_f ield.id(dest2) 

index_l_id  *  cmf.get.f ield.id(index.l) 
index_2_id  *  cmf_get_field_id(index_2) 
index_3_id  *  cmf.get.f ield_id(index_3) 
index.4_id  ■  cmf_get_f ield_id(index_4) 
sourcel.id  =  cmf_get_field_id(sourcel) 
source2_id  *  cmf _get_field_id(source2) 

if  (destl.id  .eq.  0)  then 
print  *, 

♦’Error,  the  destl  argument  to  gather2_4d  is  not  on  the  CM’ 
stop 
endif 

if  (dest2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest2  argument  to  gather2_4d  is  not  on  the  CM’ 
stop 
endif 
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if  (index_l_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index. 1  argument  to  gather2_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

+* Error,  the  index_2  argument  to  gather2_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_3  argument  to  gather2_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_4_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_4  argument  to  gather2_4d  is  not  on  the  CM’ 
stop 
endif 

if  (sourcel.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source 1  argument  to  gather2_4d  is  not  on  the  CM’ 
stop 
endif 

if  (source2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source2  argument  to  gather2_4d  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  ■  cmf_get_vp_set_id(destl) 
dest.geo  *  cm. vp.set.geometry (dest.vp.set) 

source.vp.set  *  cmf _get_vp_set_id(sourcel) 
source.geo  =  cm.vp.set.geometryCsource.vp.set) 
call  cm_set_vp_set(80urce_vp_set) 
source.temp.id  =  CM.allocate.stack.f ield(2*32) 
call  CM_u_move_lL(source..temp_id,  sourcel.id,  32) 
call  CM_u_move_lL(8ource_temp_id  +  32,  source2_id,  32) 

call  cm_set_vp_8et (dest.vp.set) 
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get_field  =  cm.allocate.stack.f ield(32) 
temp  =  cm.allocate.stack.f ield(32) 

11  *  cm_allocate_stack_field(32) 

12  *  cm.allocate.stack.f ield(32) 

13  ■  cm_allocate_staclc_f ield(32) 

*  cm_aiiocate_Btack_field(32) 

call  cm_set_context() 

dest.temp.id  *  CM.allocate.stack.f ield(2*32) 

c  select  context  for  destination 

call  cm.my.news.coordinate. 11 (temp ,0,32) 
call  cm.u.eq. constant. 11 (temp , 0 , 32) 
call  cm.logand.context.eith.testO 

rank  *  cm_geometry_rank(dest_geo) 
do  i=l, rank-1 

length  «■  cmf_get_axis_extent(destl,i-l) 
call  CM_my_news_coordinate.lL (temp , i ,32) 
call  CM_u_lt_constant_lL (temp, length, 32) 
call  CM_logand_context_with_test() 
enddo 

call  cm.u.move.zero.always. 11 (get_f ield , 32) 
call  an_u_subtract_constant_3_ll(il,index_l_id, 1,32) 
call  an_u_8ubtract_constant_3_ll(i2,index_2_id,l,32) 
call  cm_u_8ubtract_constant_3_ll(i3,index_3_id, 1,32) 
call  cm_u_8ubtract_constant_3_ll(i4,index_4_id, 1,32) 
call  cm.deposit.news.coordinate.ll (source.geo,  get_field,l, 
+  il ,32) 

call  cm_deposit_news_coordinate_ll(source_geo,  get_field,2, 
+  i2,32) 

call  cm_deposit_news_coordinate_ll(source_geo,  get_field,3, 
+  i3,32) 

call  cm.deposit.news.coordinate.ll (source.geo,  get_field,4, 
♦  i4,32) 

call  cm_get.il (dest.temp.id ,get_f ield , source.temp.id , 2*32) 
call  CM_u_move_lL(destl_id,  dest.temp.id,  32) 
call  CM_u_move_lL(dest2_id,  dest_temp_id  +  32,  32) 

call  cm_deallocate_8tack_through(dest_temp_id) 

call  CMF.set.is.modif ied(destl .MODIF) 

call  CMF.set.is.modif ied(dest2, MODIF) 

return 

end 
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subroutine  gather3_4d(destl ,  dest2,  dest3,  index.l,  index_2, 

♦  index_3,  index_4 .sourcel ,  source2,  source3) 

include  ’ /usr/include/cm/paris-conf iguration-f ort .h’ 
include  * /usr / include/cm/ CMF.def s . h ’ 

c  compute  dest  =  source (index. l,index_2,index_3,index_4) 
c  gets  source  (4-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 

c  destl  :  real  destination  field;  n-dimensional 

c  dest2  :  read  destination  field;  n-dimensional 

c  dest3  :  real  destination  field;  n-dimensional 

c  index. 1  :  integer  field  ;  first  index  of  source  array 

c  index_2  :  integer  field  ;  second  index  of  source  array 

c  index_3  :  integer  field  ;  third  index  of  source  array 

c  index_4  :  integer  field  ;  fourth  index  of  source  array 

c  sourcel  :  real  source  field;  3-dimensional 

c  source2  :  real  source  field;  3-dimensional 

c  source3  :  real  source  field;  3-dimensional 

integer  destl,  dest2,  dest3 

integer  sourcel,  source2,  source3 

integer  destl.id,  dest2_id,  dest3_id 

integer  dest.vp.set .dest.geo 

integer  index_l.index.l_id 

integer  index_2,index_2_id 

integer  index_3,index_3_id 

integer  index_4,index_4_id 

integer  sourcel.id,  source2_id,  source3_id 

integer  source.vp.set.source.gao 

integer  get.f ield , length , temp , i 1 , i2 , i3 , i4 

integer  i.rank 

integer  source.temp.id,  dest.temp.id 

destl.id  ■  cmf .get.f ield.id(destl) 
dest2_id  *  cmf .get.f ield_id(dest2) 
dest3_id  *  cmf .get.f ield_id(dest3) 

index.l.id  =  cmf .get.f ield.id(index.l) 
index_2_id  *  cmf .get.f ield_id(index_2) 
index_3_id  =  cmf .get.f ield_id(index_3) 
index_4_id  ■  cmf .get.f ield_id(index_4) 
sourcel.id  =  cmf  .get.f ield.id(sourcel) 
source2_id  =  cmf .get.f ield_id(source2) 
source3_id  =  cmf .get.f ield_id(source3) 
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if  (destl.id  .eq.  0)  then 
print  *, 

♦’Error,  the  destl  argument  to  gather3_4d  is  not  on  the  CM* 
stop 
endif 

if  (dest2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest2  argument  to  gather3_4d  is  not  on  the  CM’ 
stop 
endif 

if  (de8t3_id  .eq.  0)  then 
print  *, 

+’ Error,  the  dest3  argument  to  gather 3_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_l_id  .eq.  0)  then 
print  *, 

+’ Error,  the  index. 1  argument  to  gather3_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

+  ’ Error,  the  index_2  argument  to  gather3_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_3  argument  to  gather3_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_4_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_4  argument  to  gather3_4d  is  not  on  the  CM’ 
stop 
endif 

if  (sourcel.id  .eq.  0)  then 
print  *, 

♦’Error,  the  sourcel  argument  to  gather3_4d  is  not  on  the  CM’ 
stop 
endif 
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if  (source2_id  .eq.  0)  then 
print  * , 

+’ Error,  the  source2  argument  to  gather3_4d  is  not  on  the  CM’ 
stop 
endif 

if  (source3_id  .eq.  0)  then 
print  *, 

+’ Error,  the  source3  argument  to  gather3_4d  is  not  on  the  CM’ 
stop 
endif 

dest_vp_set  *  cmf _get_vp_set_id(destl) 
dest.geo  *  cm_vp_set_geometry(de8t„vp_set) 

source.vp.set  =  cmf _get_vp_set_id(sourcel) 
source.geo  =  cm. vp.set.geometry (source.vp.set) 
call  cm.set.vp.set (source.vp.set) 
source.temp.id  =  CM.allocate.stack.f ield(3*32) 
call  CM_u_move_lL(source_temp.id,  sourcei_id,  32) 
call  CM_u_move_lL(source_temp_id  +  32,  source2_id,  32) 
call  CM_u_move_lL(source_temp_id  ♦  64,  source3_id,  32) 

call  cm.set.vp.set (dest.vp.set) 

get_field  ■  cm.allocate.stack.f ield(32) 
temp  ■  cm.allocate.stack.f ield(32) 

11  «  cm_allocate_stack_f ield(32) 

12  «  cm.allocate.stack.f ield(32) 

13  ■  cm_allocate_stack_field(32) 

14  *  cm.allocate.stack.f ield(32) 
call  cm_set_context() 

dest_temp_id  =  CM.allocate.stack.f ield(3*32) 

c  select  context  for  destination 

call  cm_my_news_coordinate_ll(temp,0,32) 
call  cm_u_eq_constant_ll(temp,0,32) 
call  cm.logand.context.with.testO 

rank  *  cm_geometry_rank(dest_geo) 
do  i*l, rank-1 

length  =  cmf _get_axis_extent(destl ,i-l) 
call  CM_my_news_coordinate_lL(temp , i ,32) 
call  CM„u_lt .constant. 1L (temp , length , 32) 
call  CM.logand.context.with.testO 
enddo 
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call 

call 

call 

call 

call 

call 

call 

call 

call 

call 

call 

call 

call 


cm_u_move_zero_altfays.il (get.f  ield, 32) 
cm_u_subtract_constant_3_ll(il ,index_l_id, 1 ,32) 
cm_u_subtract_constant_3_ 11 ( i2 , index_2_ id , 1 , 32) 
cm_u_subtract_constant_3_ll(i3, index. 3_ id, 1 ,32) 
cm_u_subtract_constant_3_ll(i4 , index_4_id , 1 , 32) 
cm_deposit_nevs_coordinate_ll(source_geo,  get.f ield, 1 , 

11.32) 

cm.deposit.netfs.coordinate.lKsource.geo,  get_f ield, 2, 

12.32) 

cm_deposit_news_coordinate_ll(source_geo,  get.f ield, 3, 

13.32) 

cm.deposit.netfs.coordinate.lKsource.geo,  get.f ield, 4, 

14.32) 

cm_get_ll(dest_temp_id,get  field, source  temp_id,3*32) 
CM_u_move_lL(destl_id,  dest.temp.id,  32) 
CM_u_move_lL(dest2_id,  dest_temp_id  +  32,  32) 
CM_u_move_lL(dest3_id,  deat_temp_id  +  64,  32) 


call  cm.deallocate.stack.throughCdest.temp.id) 

call  CMF.set.is.modif ied(destl ,M0DIF) 

call  CMF_set_is_modif ied(dest2 ,M0DIF) 

call  CMF_set_i8_modif ied(dest3 ,MQDIF) 

return 

end 


subroutine  gather4_4d(destl ,  dest2,  dest3,  deBt4,  index, 1, 
+  index_2,  index_3,  index_4,  sourcel, 

♦  source2,  source3,  source4) 

include  ’ /usr/include/cm/paris -conf igurat ion-fort . h ’ 
include  ’/usr/include/cm/CMF.defs .h’ 

c  compute  dest  =  source ( index. 1 , index_2 , index_3 , index_4) 
c  gets  source  (4-dimensional)  for  dest  (n-dimensional) 
c  the  dest  and  index  fields  must  be  in  the  same  vp  set 
c 

c  parameters 
c  destl 

c  dest2 

c  dest3 

c  dest4 

c  index. 1 

c  index_2 

c  index_3 

c  index_4 

c  sourcel 


real  destination  field;  n-dimensional 
real  destination  field;  n-dimensional 
real  destination  field;  n-dimensional 
real  destination  field;  n-dimensional 
integer  field  ;  first  index  of  source  array 
integer  field  ;  second  index  of  source  array 
integer  field  ;  third  index  of  source  array 
integer  field  :  fourth  index  cf  source  arrey 
real  source  field;  3-dimensional 
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c  source2  :  real  source  field;  3-dimensional 

c  source3  :  real  source  field;  3-dimensional 

c  source4  :  real  source  field;  3-dimensional 

integer  destl,  dest2,  dest3,  dest4 
integer  sourcel,  source2,  source3,  source4 
integer  destl.id,  dest2_id,  dest3_id,  dest4_id 
integer  dest_vp_set ,dest_geo 
integer  index. 1 , index. l.id 
integer  index_2,index_2_id 
integer  index_3,index_3_id 
integer  index_4,index_4_id 

integer  sourcel.id,  source2_id,  source3_id,  source4_id 
integer  source.vp.set.source.geo 
integer  get.f < d , length , temp , il , i2 , i3 , i4 
integer  i.rank 

integer  source.temp.id,  dest.temp.id 

deacl.id  *  cmf .get.f ield.id(destl) 
dest2_id  =  cmf .get.f ield_id(dest2) 
dest3_id  =  cmf .get.f ield_id(dest3) 
dest4_id  *  cmf .get.f ield_id(dest4) 

index.l.id  *  cmf.get.f ield.id(index.l) 
index. 2. id  «  cmf_get_field.id<index.2) 
index_3.id  *  cmf .get.f ield.id(index_3) 
index_4_id  ■  cmf.get.f ield_id(index.4) 
sourcel.id  «  cmf.get.f ield.id(sourcel) 

80urce2_id  ■  cmf .get.f ield_id(source2) 
source3_id  =  cmf_get_field_id(source3) 
source4_id  *  cmf.get.f ield_id(source4) 

if  (destl.id  .  eq.  0)  then 
print  *, 

+’ Error,  the  destl  argument  to  gather4_4d  iB  not  on  the  CM’ 
stop 
endif 

if  (de8t2_id  .eq.  0)  then 
print  * , 

+ ’Error,  the  dest2  argument  to  gather4_4d  is  not  on  the  CM’ 
stop 
endif 

if  (de8t3_id  .eq.  0)  then 

pi-rvt  ?, 

+’ Error,  the  dest3  argument  to  gather4_4d  is  not  on  the  CM’ 


98 


stop 

endif 

if  (dest4_id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest4  argument  to  gather4_4d  is  not  on  the  CM* 
stop 
endif 


if  ( index. 1_ id  .eq.  0)  then 
print  *, 

+’ Error,  the  index. 1  argument  to  gather4_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

+’ Error,  the  index_2  argument  to  gather4_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_3  argument  to  gather4_4d  is  not  on  the  CM’ 
stop 
endif 

if  (index_4_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_4  argument  to  gather4_4d  is  not  on  the  CM’ 
stop 
endif 

if  (sourcel.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source 1  argument  to  gather4_4d  is  not  on  the  CM' 
stop 
endif 

if  (80urce2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source2  argument  to  gather4_4d  is  not  on  the  CM’ 
stop 
endif 

if  (source3_id  .eq.  0)  then 
print  *, 
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+’ Error,  the  source3  argument  to  gather4_4d  is  not  on  the  CM’ 
stop 
endif 

if  (source4_id  .eq.  0)  then 
print  *, 

+’ Error,  the  source4  argument  to  gather4_4d  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  *  cmf _get_vp_set_id<destl) 
dest_geo  =  cm_vp_set_geometry  (de-’t.vp.set) 

source_vp_set  *  cmf _get_vp_set_id(sourcel) 
source_geo  *  cm_vp_set_geometry(source_vp_set) 
call  cm_set_vp_set(source_vp_set) 
source_temp_id  =  CM_allocate_stack_f ield(4*32) 
call  CM_u_move_lL(source_temp_id,  sourcel.id,  32) 
call  CM_u_move_lL (source. temp.id  f  32,  source2_id,  32) 
call  CM_u_move_lL(source_temp_id  +  64,  source3.id,  32) 
call  CM_u_move_lL(source_temp_id  +  96,  source4_id,  32) 

call  cm_8et_vp.8et(de8t_vp.aet) 

get.field  »  cm_allocate_stack_f ield(32) 
temp  «  cm_allocate_8tack_field(32) 

11  *  cm.allocate.stack.f ield(32) 

12  *  cm.allocate.stack.f ield(32) 

13  *  cm.allocate.stack.f ield(32) 

14  ■  cm_allocate_8tack_f ield(32) 
call  cm.set.contextO 

dest_temp_id  *  CM_allocate_stack_f ield(4*32) 

c  select  context  for  destination 

call  cm_my_news_coordinate_ll(temp ,0 ,32) 
call  cm_u_eq_constant_ 11 (temp, 0,32) 
call  cm_logand_context_with_test() 

rank  *  cm_geometry_rank(dest_geo) 
do  i*l, rank-1 

length  *  cmf _get_axis_extent(destl ,i-l) 
call  CM.my.ness.coordinate. 1L (temp , i , 32) 
call  CM.u.lt.constant. lL(temp , length , 32) 
call  CM.logand_context_with.test ( ) 
enddo 

call  cm_u_move_zero_always_ll(get_f ield,32) 
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call 

call 

call 

call 

call 

call 

call 

call 

call 

call 

call 

call 

call 


cm_u_subtract_constant_3_ll(il ,index_l_id, 1,32) 
cm_u_subtract_constant_3_ll(i2, index_2_id, 1,32) 
cm_u_subtract_constant_3_ll(i3 , index_3_id , 1,32) 
cm.u.subtract _constant_3_ 11 ( i4 , index_4_id , 1 , 32) 
cm.deposit.news.coordinate.llCsource.geo,  get.f ield, 1 , 

11 .32) 

cm.deposit.news.coordinate.lKsource.geo,  get_f ield,2, 

12.32) 

cm.deposit.nevs.coordinate.lKsource.geo,  get_f ield,3, 

13 .32) 

cm_deposit_news_coordinate_ll(source_geo,  get_f ield,4, 

14.32) 

cm_get_ll(dest_temp_id,get_f ield, source.temp. id, 4*32) 
CM_u_move_lL(destl_id,  dest.temp.id,  32) 
CM_u_move_lL(dest2_id,  dest.temp.id  +  32,  32) 
CM_u_move_lL(dest3_id,  dest.temp.id  +  64,  32) 
CM_u_move_lL(dest4_id,  dest.temp.id  +  96,  32) 


call  cm_deallocate_stack_through(dest_temp_id) 

call  CMF_set_is_modif iedCdestl ,M0DIF) 

call  CMF_set_is_modif ied(dest2 .MODIF) 

call  CHF_8et_is_modif ied(dest3 , MODIF) 

call  CMF_set_is_modif ied(dest4 , MODIF) 

return 

end 


subroutine  scatter_add_l (dest , index. 1 , source) 
include  ’ /usr/include/cm/paris-conf igur at ion-fort .h’ 
include  ’ /u3r/include/cm/CMF_def s .h’ 


c  compute  dest(index.l)  *  dest(index.l)  ♦  source 
c  sends  source  (n-dimensional)  to  dest  (1-dimensional) 
c 

c  parameters 

c  dest  :  real  destination  field;  1-dimensional 

c  index. 1  :  integer  field  ;  first  index  of  dest  array 

c  source  :  real  source  field 


integer  dest, index. 1, source 
integer  dest_id,index_l_id,source_id 

integer  source.vp.set, dest. vp.set , dest _geo,source_geo,send_f ield 
integer  length, temp.il, rank, i 
integer  type.slen.elen 

dest.id  s  cmf .get.f ield.id(dest) 
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index.l.id  =  cmf_get_field_id(index_l) 
source.id  =  cmf  _get_f  ield_id(source) 

if  (dest.id  .eq.  0)  then 
print  *, 

+ ’Error,  the  dest  argument  to  scatter_add_l  is  not  on  the  CM’ 
stop 
endif 

if  (index_l_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index.l  argument  to  scatter_add_l  is  not  on  the  CM’ 
stop 
endif 

if  (source.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source  argument  to  scatter_add_l  is  not  on  the  CM’ 
stop 
endif 

dest_vp_set  »  cmf _get_vp_set_id<dest) 
dest_geo  *  cm_vp_set_geometry(dest_vp_set) 

8ource_vp_8et  *  cmf _get_vp_set_id(source) 
source.geo  *  cm_vp_set_geometry(source_rp_set) 
call  cm_8et_vp_set(source_vp_set) 

call  cm_set_context() 

send.field  *  cm_allocate_stack_field(32) 
temp  =  cm_allocate_stack_field(32) 
il  *  cm.allocate.stack.f ield(32) 

call  cm_my_news_coordinate_ 11 (temp, 0,32) 
call  cm_u_eq_con8tant_ 11 (temp, 0,32) 
call  cm_logand_context_with_test() 

rank  *  CM_geometry_rank( source.geo) 
do  i*l, rank-1 

length  *  cmf_get_axis.extent(source,i-l) 
call  CM_my_news_coordinate.lL (temp , i ,32) 
call  CM.u.lt.constant. lL(temp , length , 32) 
call  CM_logand_context_with_test() 
enddo 

call  cm_u_move_zero_always_ll(send_f ield,32) 

call  cm_s_subtract_constant_3_ll(il ,index_l_id, 1 ,32) 
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call  cm_deposit_news_coordinate_ll(dest_geo,send_f ield, 1 , 
+  11,32) 


type  *  cmf _get_data_type(dest) 
elen  =  cmf .get.exponent.len(dest) 
slen  =  cmf _get_integer_len(dest) 

if  (type.eq.cmssl.float)  then 

call  cm.send.vith.f .add. 11 (dest.id.send.f ield, source. id, 
+  '  23,8,cm_no_f ield) 

else  if  (type.eq.cmssl_s_integer)  then 

call  cm_send_with_s_add.il (dest.id.send.f ield, source. id, 
+  slen .cm.no.f ield) 

else  if  (type.eq.cmssl.u.integer)  then 

cadi  cm_send_with_u_add.il (dest.id.send.f ield, source. id, 
+  slen, cm.no.f ield) 

else 

write  (*,0  ’  ***  scatter.add.l :  bad  array  data  type’ 
endif 

call  cm_deallocate_stack_through(send_f ield) 
call  CMF.set.is.modif ied(dest ,M0DIF) 
return 
end 


subroutine  scatter.min. 1 (dest , index. 1 , source) 
include  ’ /usr/include/cm/paris-conf iguration-f ort .h’ 
include  ’ /usr/include/cm/CHF.def s ,h* 


c  compute  dest(index.l)  *  min(dest(index_l) ,  source) 
c  sends  source  (n-dimensional)  to  dest  (1-dimensional) 
c 

c  parameters 

c  dest  :  real  destination  field;  1-dimensional 

c  index. 1  :  integer  field  ;  first  index  of  dest  aurray 

c  source  :  real  source  field 


integer  dest, index. 1, source 
integer  dest. id, index. 1. id, source. id 

integer  source. vp.set , dest. vp.set , dest .geo , source.geo , send.f ield 
integer  length, temp, il, rank, i 
integer  type, slen, elen 

dest.id  =  cmf .get.f ield.id(dest) 
index.l.id  =  cmf .get.f ield.id(index.l) 

80urce_id  =  cmf .get.f ield.id(source) 
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if  (dest.id  .eq.  0)  then 
print  * , 

♦'Error,  the  dest  argument  to  scatter _min_l  is  not  on  the  CM’ 
stop 
endif 

if  (index_l_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index. 1  argument  to  scatter.min.l  is  not  on  the  CM’ 
stop 
endif 

if  (source.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source  argument  to  scatter.min.l  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  =  cmf _get_vp_set_id(dest) 
dest.geo  *  cm_vp_set_geometry(dest_vp_set) 

source.vp.set  *  cmf _get_vp_set_id(source) 
source.geo  *  cm_vp_set_geometry(source_vp_set) 
call  cm_set_vp_set(80urce_vp_set) 

call  cm.set.contextO 

send.field  =  cm.allocate.stack.f ield(32) 
temp  *  cm.allocate.stack.f ield(32) 
il  *  cm.allocate.stack.f ield(32) 

call  cm.my.news.coordinate. 11 (temp ,0,32) 
call  cm_u_eq_constant_ll(temp,0,32) 
call  cm_logand_context_with_test() 

rank  ■  CM_geometry_rank(source_geo) 
do  i*l, rank-1 

length  «  cmf .get.axis.extent (source, i-1) 
call  CM_my_neHs_coordinate.lL (temp , i ,32) 
call  CM_u_lt_constant.lL (temp, length, 32) 
call  CM_logand_context_vith_test() 
enddo 

call  cm_u_move_zero_always_ll(send_f ield,32) 

call  cm_s_subtract_constant_3_ll(il , index. 1. id, 1,32) 

call  cm_deposit_nevs_coordinate_ll(dest_geo, send.field, 1 , 

+  il ,32) 
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type  =  cmf _get.data.type (dest) 
elen  =  cmf .get.exponent.len(dest) 
slen  =  cmf .get.integer.len(dest) 

if  (type.eq.cmssl_float)  then 

call  cm_send_with_f_min.il (dest .id, send.f ield, source. id, 
+  23,8,cm_no_field) 

else  if  (type.eq.cmssl_s_integer)  then 

call  cm_send_with_s_min.il (dest .id, send.f ield, source. id, 

♦  slen.cm.no.f ield) 
else  if  (type.eq.cmssl.u.integer)  then 

call  cm.send.with.u.min. 11 (dest .id, send.f ield, source. id, 

♦  slen.cm.no.f ield) 
else 

write  (*,*)  ’  ***  scatter .ain.l :  bad  array  data  type’ 
endif 

call  cm_deallocate_stack_through( send.f ield) 
call  CMF.set.is.modif ied(dest ,M0DIF) 
return 
end 


subroutine  scatter.max. 1 (dest .index. 1 .source) 
include  ’ /usr/include/cm/paris-conf iguration-f ort .h  ’ 
include  ’ /usr/ include/cm/ CMF.def s .h ’ 


c  compute  dest(index.l)  ■  max ( dest ( index. 1) ,  source) 
c  sends  source  (n-dimensional)  to  dest  (1-dimensional) 
c 

c  parameters 

c  dest  :  real  destination  field;  l-dimens ional 

c  index. 1  ;  integer  field  ;  first  index  of  dest  array 

c  source  :  real  source  field 


integer  dest , index. 1 , source 


integer  dest_id,index_l_id,source_id 

integer  source.vp.set , dest.vp.set , dest _geo , source.geo .send.f ield 
integer  length, temp.il, rank,! 
integer  type, slen, elen 


dest.id  *  cmf .get.f ield.id(dest) 
index.l.id  *  cmf .get.f ield.id(index.l) 
source.id  *  cmf .get.f ield.id(source) 


if  (dest.id  .eq.  0)  then 
print  * , 

+’ Error,  the  dest  argument  to  scatter.max. 1  is  not  on  the  CK’ 

8tOp 
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endif 


if  (index_l_id  .eq.  0)  then 
print  * , 

+' Error,  the  index. 1  argument  to  scatter.max.l  is  not  on  the  CM' 
stop 
end’f 

if  (8ource_id  .eq.  0)  then 
print  *, 

+ 'Error,  the  source  argument  to  scatter.max.l  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  ■  cmf  _get_vp_set_'.d(dest) 
dest.geo  *  cm_vp_set_geometry(dest_vp_set) 

source.vp.set  *  cmf _get_vp_set_id(source) 
source.geo  =  cm_vp_set_geometry(source_vp_set) 
call  cm_set.vp_set(80urce_vp_8et) 

call  cm.set.contextO 

8end_field  *  cm.allocate.stack.f ield(32) 
temp  ■  cm.allocate.stack.f ield(32) 
il  =  cm_allocate_stack_field(32) 

call  cm_my_news_coordinate.il (temp, 0,32) 
call  cm_u_eq_constant.il (temp, 0,32) 
call  cm_logand_context_with_test() 

rank  ■  CM_geometry_rank (source.geo) 
do  i«l, rank-1 

length  «=  cmf .get.axis.extent (source , i-1) 
call  CM_my_news_coordinate_lL(temp , i ,32) 
call  CM_u_lt_constant.lL (temp, length, 32) 
call  CM_logand_context_vith_test() 
enddo 

call  cm_u_move_zero_always_ll(send_f ield,32) 

call  cm_s_subtract_con8tant_3_ll(il , index.l.id, 1,32) 

call  cm_deposit_news_coordinate_ll(dest_geo,send_f ield, 1 , 

+  il ,32) 

type  *  cmf _get_data_type(dest) 
elen  =  cmf _get_exponent_len(dest) 
slen  =  cmf_get_integer_len(dest) 
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if  (type.eq.cmssl.float)  then 

call  cm.senc’ .with.f .max. 11 (dest_id,send_f ield, source. id, 

23,8,cm_no_fi9ld) 

else  if  Uvpe.eq.cmssl.s.integer)  then 

call  cm_t?end_with_s_max_  11  (dest.  id,  send.f  ield,  source,  id, 
+  slen,cm_no_field) 

else  if  (type.eq.cmssl.u.integer)  then 

call  cm_send.vith_u.max_ 11 (dest. id, send.f ield, source. id, 
+  sl9n,cm_no_field) 

else 

write  (*,*)  '  ***  scatter.uax.l:  bad  array  data  type’ 
endif 

call  cm_deallocate_stack_through(send_f ield) 
call  CMF.set.is.modif ied(dest ,M0DIF) 
return 
end 


subroutine  scatter.add.2 ( dest , index. 1 , index_2 , source) 
include  ’ /usr/include/cm/paris-conf iguration-f ort .h’ 
include  ’ /usr/include/cm/CMF_def s .h’ 

c  compute  dest ( index. l,index_2)  *  dest ( index. l,index_2)  +  source 
c  sends  source  (n-dimensional)  to  dejt  (2-dimensiona1 ) 
c 

c  parameters 

c  dest  :  real  destination  field; 2-dimensional 

c  index. 1  :  integer  field  ;  first  index  of  dest  array 

c  index_2  :  integer  field  ;  second  index  of  dest  array 

c  source  :  real  source  field 

integer  dest , index.l , index_2 , source 

integer  dest. id, index.l. id, index. 2. id, source. id 
integer  source.vp.set , dest. vp.set , dest _geo .source.geo, send.f ield 
integer  length, temp, il,i2, rank, i 
integer  type,slen,elen 

dest.id  *  cmf _g-)t_f ield.id(dest) 
index.l  id  «  cmf .get.f ield.id(indox.l) 
index_2_id  *  cmf.get.f ield_id(index_2) 
source.id  =  cmf.get.f ield.id(source) 

if  (dest.id  .eq.  0)  the:: 
print  *, 

+’ Error,  the  dest  argument  to  scatter_add_2  is  not  on  the  CM’ 
stop 
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endif 


if  (index.l.id  .eq.  0)  then 
print  *, 

♦’Error,  the  index.l  argument  to  scatter.add.2  is  not  on  the  CM* 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  * , 

♦’Error,  the  index_2  argument  to  scatter_add_2  is  not  on  the  CM’ 
;top 
endif 

if  (source.id  .eq.  0)  then 
print  *, 

♦’Error,  the  source  argument  to  scatter_add_2  is  not  on  the  CM’ 
stop 
endif 

dest_vp_set  =  cmf _get_vp_set_id(dest) 
dest_geo  =  cm_vp_set_geometry<dest_vp_set) 

source_vp_set  *  cmf _get_vp_set_id(source) 
source_geo  ■=  cm.vp.set.geometry ( source. vp.set) 
call  cm.set.  vp.set  (source.trp.set) 

call  cm_set_context() 

send.field  *  cm.allocate.stack.f ield(32) 
temp  «  cm.allocate.stack.f ield(32) 

11  *  cm.allocate.stack.f ield(32) 

12  ■  cm.allocate.stack.f ield(32) 

call  cm_my_news_coordinate.il (temp, 0,32) 
call  cm_u_eq_con3t ant. 11 (temp ,0,32) 
call  cm.logand.context.vith.testO 

rank  *  CM_geometry„rank(source_geo) 
do  i*l, rank-1 

length  *  cmf_get_axis_extent(source,i-l) 
call  CM_my_news_coordinate_lL(temp , i ,32) 
call  CM_u_lt_constant_lL(temp, length, 32) 
call  CM.logand.context.with.testO 
enddo 

call  cm.u.move.zero.alvays.ll (send.field, 32) 

call  an_s_subtract_constant_3_ll(il , index. 1. id, 1 ,32) 
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call  cm_s_subtract_constant_3_ll(i2 , index_2_id , 1 , 32) 
call  cm_deposit_nevs_coordinate_ll(dest_3eo,8end_f ield, 1 , 
+  il ,32) 

call  cm_deposit_news_coordinate_ 11 (dest.geo , send.f ield , 2 , 
+  i2,32) 


type  ■  cmf _get.data.type (dest) 
elen  =  cmf .get.exponent.len(dest) 
slen  «  cmf _get_integer_len(dest) 

if  (type.eq.cmssl.float)  then 

call  cm.send.vith.f .add. 11 (dest. id, send.f ield, source.id, 
+  23,8, cm_no_f ield) 

else  if  (type.eq.cmssl.s.integer)  then 

call  cm_send_with_s_add.il (dest. id .send.f ield , source.id , 
+  slen, cm_no_f ield) 

else  if  (type.eq.cmssl_u_integer)  then 

call  cm_send_with_u_add.il (dest _id .send.f ield , source.id , 
+  slen, cm_no_f ield) 

else 

write  (*,*)  *  ***  8catter_add_2:  bad  array  data  type’ 
endif 

call  cm_deallocate_stack_through(send_f ield) 
call  CMF_set_is_modif ied(dest .MODIF) 
return 
end 


subroutine  scatter _min_2(dest , index. 1 , index_2 , source) 
include  ’/usr/include/cm/paris-conf iguration-f ort .h’ 
include  ’ /usr/include/cm/ CMF.def s . h ’ 


compute  dest(index_l,index_2)  =  min(dest (index. 1 ,index_2) .source) 
sends  source  (n-dimensional)  to  dest  (2-dimensional) 


parameters 
dest 
index. 1 
index .2 
source 


real  destination  field; 2-dimensional 
integer  field  ;  first  index  of  dest  array 
integer  field  ;  second  index  of  dest  array 
real  source  field 


integer  dest, index. 1 ,index_2, source 

integer  dest. id , index. 1. id , index_2_ id , source. id 
integer  source.vp.set , dest. vp.set , dest.geo , source.geo , send.f ield 
integer  length, temp, il,i2,rank,i 
integer  type, slen, elen 
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dest.id  =  cmf _get_f ield_id(deat) 
index_l_id  *=  cmf _get_f ield_id(index_l) 
index_2_id  ■  cmf _get_f ield_id(index_2) 
source.id  =  cmf _get_f ield.id(source) 

if  (dest.id  .  eq.  0)  then 
print  *, 

♦’Error,  the  dest  argument  to  scatter_min_2  is  not  on  the  CM’ 
stop 
endif 

if  (index.l.id  .eq.  0)  then 
print  *, 

♦’Error,  the  index.l  argument  to  scatter_min_2  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_2  argument  to  scatter _min_2  is  not  on  the  CM’ 

8tOp 

endif 

if  (source. id  .eq.  0)  then 
print  *, 

♦’Error,  the  source  argument  to  scatter _min_2  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  *  cmf _get_vp_set_id(dest) 
dest.geo  ■  cm_vp_set_g9ometry(dest_vp_set) 

source.vp.set  =  cmf _get_vp_set_id(source) 
source.geo  *=  cm. vp.set.geometry (source.vp.set) 
call  cm.set.vp.set (source.vp.set) 

call  cm.set.contextO 

send.field  *  cm.allocate.stack.f ield(32) 
temp  *  cm.allocate.stack.f ield(32) 

11  ■  cm.allocate.stack.f ield(32) 

12  «  cm.allocate.stack.f ield(32) 

call  cm.my.news.coordinate. 11 (temp ,0,32) 
call  cm_u_eq_constant_ll(temp,0,32) 
call  cm_logand_context_with_teBt() 

rank  *  CM_geometry_rank(source_geo) 
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do  i=l, rank-1 

length  *  cmf .get.axis.extent (source, i-1) 
call  CM_my_news_coordinate_lL(temp , i ,32) 
call  CM_u_lt_constant_lL (temp, length, 32) 
call  CM_logand_context _with_test ( ) 
enddo 

call  cm_u_move_zero_always_ 11 (send.f ield , 32) 
call  cm. s.subtract. const ant_3_ 11 (il, index. 1. id, 1,32) 
call  cm_8_subtract_constant_3_ll(i2,index_2_id, 1,32) 
call  cm_deposit_news_coordinate_ll(dest_geo,send_field, 1 , 

+  il ,32) 

cadi  cm_deposit_news_coordinate_ll(dest_geo,send_field,2, 

+  i.2,32) 

type  ■  cmf _get.data.type (dest) 
elen  *  cmf _get_exponent_len(dest) 
slen  *  cmf_get_integer_len(dest) 

if  (type.eq.cmssl_float)  then 

call  cm_send_with_f_min.il (dest.id , send.f ield , source_id , 
+  23,8,cm_no_f ield) 

else  if  (type.eq.cmssl.s.integer)  then 

call  cm_send_with_s_min.il (dest.id , send.f ield , source. id , 
+  8len,cm_no_field) 

else  if  (type.eq.cmssl.u.integer)  then 

call  cm_8end_with_u_min„ll (dest.id , send.f ield , source.id , 
+  8len,cm_no_f ield) 

else 

write  (*,*)  ’  ***  scatter _min_2:  bad  array  data  type* 
endif 

call  cm_deallocate_8tack_through(send_f ield) 
call  CMF.set.is.modif ied(dest ,H0DIF) 
return 
end 


subroutine  scatter _maLX_2(dest ,  index.  1 ,  index_2 ,  source) 
include  ’/usr/include/cm/pariB-conf igiiration-fort .h’ 
include  ’ /usr / include/ cm/ CMF. def s . h ’ 


c  compute  dest( index. l,index_2)  «  max (destC index. 1 ,index_2) .source) 


sends  source  (n-dimensional)  to  dest  (2-dimensional) 


parameters 
dest 
index. 1 
index_2 
source 


real  destination  f ield; 2-dimensional 
integer  field  ;  first  index  of  dest  array 
integer  field  ;  second  index  of  dest  array 
real  source  field 
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integer  dest , index. 1 ,index_2, source 


integer  dest. id, index. 1. id, index_2_id, source. id 
integer  source.vp.set , dest.vp.set , dest.geo , source.geo ,send_f ield 
integer  length, temp, il,i2, rank, i 
integer  type ,slen,elen 

dest.id  85  cmf.get.f ield.id(dest) 
index.l.id  =  cmf_get_field_id(index_l) 
index_2_id  =  cmf.get.f ield_id(index_2) 
source.id  =  cmf.get.f ield.id(source) 

if  (dest.id  .eq.  0)  then 
print  *, 

+’ Error,  the  dest  argument  to  scatter _max_2  is  not  on  the  CM* 
stop 
endif 


if  (index.l.id  .eq.  0)  then 
print  *, 

+* Error,  the  index. 1  argument  to  scatter _max_2  is  not  on  the  CM’ 
stop 
endif 


if  (index_2_id  .eq.  0)  then 
print  *, 

+’ Error,  the  index_2  argument  to  scatter .max. 2  is  not  on  the  CM’ 
stop 
endif 


if  (source.id  .eq.  0)  then 
print  *, 

+’ Error,  the  source  argument  to  scatter.max_2  is  not  on  the  CM’ 
stop 
endif 


dest.vp.set  «  cmf .get _vp_ set. id( dest) 
dest.geo  *  cm_vp_set_geometry(dest_vp_Bet) 

source.vp.set  *  cmf  .get .vp.set. id (source) 
source.geo  *  cm. vp_set_geometry(source_ vp.set) 
call  cm.set.vp.set (source.vp.set) 


call  cm.set.context 


0 


send.field  *  cm.allocate.stack.f ield(32) 
temp  ■  cm.allocate.stack.f ield(32) 


112 


11  =  cm_allocate_stack_f ield(32) 

12  =  cm_allocate_stack_field(32) 

call  cm.my.nevs, coordinate, 11 (temp ,0,32) 
call  cm_u_eq_constant_ll(temp,0,32) 
call  cm_logand_context_vith_test() 

rank  *  CM_geometry_rank(source_geo) 
do  i=l, rank-1 

length  =  cmf  _get_axis_extent(source,i-l) 
cadi  CM_my_new8_coordinate_lL(temp , i ,32) 
call  CM_u_lt_constant_lL (temp, length, 32) 
call  CM_logand_context_with_test() 
enddo 

call  cm_u_move_zero_always_ll (send_f ield , 32) 
call  cm_8_subtract_congtant_3_ll(il , index_l_id, 1 ,32) 
call  cm_8_subtract_constant_3_ll(i2,index_2_id, 1,32) 
call  cm_deposit_news_coordinate_ll(dest_geo,send_field, 1 , 

+  11,32) 

call  cm_deposit_news_coordinate_ll(dest_geo,8end_f ield, 2, 

♦  i2,32) 

type  «  cmf_get_data.type(dest) 
elen  *  cmf _get_exponent_len(dest) 
slen  =  cmf _get_integer_len(dest) 

if  (type.eq.cmssl.float)  then 

call  cm.send.vith.f _max_ 11 (dest.id , send.f ield , source, id , 

+  23,8,cm_no_f ield) 

else  if  (type.eq.cmssl.s.integer)  then 

call  cm_send_with_s_max_ 11 (dest_ id , send.f ield , source, id , 

+  8len,cm_no_f ield) 

else  if  (type.eq.cmssl_u_integer)  then 

call  cm_send_with_u_max_ll(dest_id, send.f ield, source_id, 

+  slen, cm.no.f ield) 

else 

write  (*,*)  ’  ***  scatter _max_2:  bad  array  data  type’ 
endif 

call  cm_deallocate_stack_through(send_f ield) 
call  CMF_set_is_modif ied(dest ,M0DIF) 
return 
end 

subroutine  scatter_add_3(dest , index. 1 , index_2 , index_3 , source) 
include  ’ /usr/include/cm/paris-conf iguration-f ort .h’ 
include  ’/usr/include/cm/CMF.defs .h’ 

c  compute  dest (index, l,index_2,index_3)  * 
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c  dest ( index. l,index_2,index_3)  +  source 

c  sends  source  (n-dimensional)  to  dest  (3-dimensional) 


c  parameters 

c  dest  :  real  destination  field; 3-dimensional 

c  index. 1  :  integer  field  ;  first  index  of  dest  array 

c  index_2  :  integer  field  ;  second  index  of  dest  array 

c  index_3  :  integer  field  ;  third  index  of  dest  array 

c  source  :  real  source  field 

integer  dest , index. 1 , index_2 , index_3 , source 

integer  dest.id, index. l.id, index_2_id, index_3_id , Bource. id 
integer  source_vp_set,dest_vp_set , dest _geo, sour ce.geo, send. field 
integer  length .temp ,11,12,13, rank , 1 
Integer  type,slen,elen 

dest.id  «  cmf.get.f ield.id(dest) 
index.l.id  ■  cmf.get.f ield_id(index_l) 
index_2_id  *  cmf.get.f ield_id(index_2) 
index_3_id  =  cmf_get_field_id(index_3) 
source.id  *  cmf .get.f ield.id(source) 

if  (dest.id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest  argument  to  scatter_add_3  is  not  on  the  CM’ 
stop 
endif 

if  (index.l.id  .eq.  0)  then 
print  *, 

♦’Error,  the  index.l  argument  to  scatter_add_3  is  not  on  the  CM’ 

8tOp 

endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index.2  argument  to  scatter. add_3  is  not  on  the  CM’ 
8t0p 
endif 

if  (index_3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_3  argument  to  scatter_add_3  is  not  on  the  CM’ 
stop 
endif 

if  (source.id  .eq.  0)  then 
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print  *, 

+’ Error,  the  source  argument  to  scatter_add_3  is  not  on  the  CM’ 
stop 
endif 

dest_vp_set  =  cmf _get_vp_set_id(dest) 
dest.geo  =  cm.vp.set.geometry (dest.vp.set) 

source_vp_set  c  cmf _get_vp_set_id(source) 
source_geo  =  cm.vp.set.geometry (source.vp.set) 
call  cm_set_vp_8et(source_vp_Bet) 

call  cm_set_context() 

send.field  ■  cm.allocate.stack.f ield(32) 
temp  ■  cm.allocate.stack.f ield(32) 

11  *  cm_allocate_stack_f ield(32) 

12  *  cm_allocate_stack_f ield(32) 

13  ■  cm_allocate_stack_f ield(32) 

call  cm_my.news_coordinate.il (temp, 0,32) 
call  cm_u_eq_constant.il (temp, 0,32) 
call  cm.logand.context.with.t est ( ) 

rank  «  CM_geometry_rank(source_geo) 
do  i*l, rank-1 

length  *  cmf .get.axis.extent (source, i-1) 
call  CM_my_nevs_coordinate_ 1L (temp , i , 32) 
call  CM_u_lt_constant_lL(temp, length, 32) 
call  CM.logand.context.with.testO 
enddo 

call  cm.u.move.zero.alvays.ll (send.field, 32) 
call  cm_s_8ubtract_constant_3_ll(il,index_l_id, 1,32) 
call  cm_a_8ubtract_constant_3_ll(i2 , index_2_id , 1 , 32) 
call  cm_s_8ubtract_constant_3_ll(i3,index_3_id, 1,32) 
call  cm_deposit_news_coordinate_ll(dest_geo,Bend_field,l , 

♦  il ,32) 

call  cm.deposit .news. coordinate. 11 (dest.geo, send.field, 2, 

+  i2,32) 

call  cm. deposit_nev8_coordinate_ll(dest_geo, send.field, 3, 

+  i3,32) 

type  ■  cmf _get_data_type(dest) 
elen  *  cmf_get_exponent_len(dest) 
slen  ■  cmf_get_integer_len(dest) 

if  (type.eq.cmssl.float)  then 
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call  cm.send.with.f _add_ll(dest_ id, send.field, source. id, 

♦  23,8,cm_no_field) 

else  if  (type.eq.cmssl.s.integer)  then 

call  cm_send_with_s_add_ll(dest_id,send_field,source_id, 

+  slen, cm_no_f ield) 

else  if  (type.eq.cmssl_u_integer)  then 

call  cm_send_with_u_add.il (dest.id , send.field , source. id , 

+  slen, cm.no.f ield) 

else 

write  (*,*)  ’  ***  scatter_add_3:  bad  array  data  type’ 
endif 

call  cm_deallocate_8tack_through(send_field) 
call  CMF.set.is.modif ied(dest ,M0DIF) 
return 
end 

subroutine  scatter _min_3(dest , index. 1 , index_2 , index_3 , source) 
include  ’/usr/include/cm/paris-conf iguration-fort .h* 
include  ’ /usr/ include/ cm/CMF_def s .h’ 

c  compute  dest(index_l,index_2,index_3)  = 
c  min(dest(index_l,index_2,index_3) .source) 

c  sends  source  (n- dimensional)  to  dest  (3-dimensional) 
c 

c  parameters 

c  dest  :  real  destination  f ield; 3-dimensional 

c  index. 1  :  integer  field  ;  first  index  of  deBt  array 

c  index_2  :  integer  field  ;  second  index  of  dest  array 

c  index.3  :  integer  field  ;  third  index  of  dest  array 

c  source  :  real  source  field 

integer  dest , index. 1 , index_2 , index. 3 , source 

integer  dest.id, index. l_id,index_2_id,index_3_id,source_id 
integer  source.vp.set .dest.vp.set .dest.geo .source.geo .send.f ield 
integer  length .temp , il , i2 , i3 .rank , i 
integer  type, slen, elen 

dest.id  *  cmf .get.f ield.id(dest) 
index.l.id  *  cmf _get_field_id(index_l) 
index_2_id  *  cmf.get.f ield_id(index_2) 
index_3_id  *  cmf _get_field_id(index_3) 
source.id  =  cmf  .get.f ield.id(source) 

if  (dest.id  .eq.  0)  then 
print  *, 

♦’Error,  the  dest  argument  to  scatter _min_3  is  not  on  the  CM’ 
stop 
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endif 


if  (index_l_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index.l  argument  to  scatter_min_3  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

+  ’ Error,  the  index_2  argument  to  scatter_min_3  is  not  on  the  CM’ 
stop 
endif 

if  (index_3_id  .eq.  0)  then 
print  *, 

♦’Error,  the  index_3  argument  to  scatter_min_3  is  not  on  the  CM’ 
stop 
endif 

if  (Bource_id  .eq.  0)  then 
print  *, 

♦’Error,  the  source  argument  to  scatter _min_3  is  not  on  the  CM’ 
stop 
endif 

deat_vp_set  «  cmf _get_vp_set_id(dest) 
dest.geo  «  cm_vp_set_geometry(dest_vp_set) 

source. vp_set  *  cmf _get_vp_set_id(source) 
source.geo  *  cm_vp_set_geometry(source_vp_set) 
call  cm_set_vp_set(8o\irce_vp_set) 

call  cm_8et_context() 

send.field  *  cm.allocate.stack.f ield(32) 
temp  *  cm.allocate.stack.f ield(32) 

11  *  cm.allocate.stack.f ield(32) 

12  ■  cm.allocate.stack.f ield(32) 

13  *  cm.allocate.stack.f ield(32) 

call  cm_my_news_coordinate.il (temp ,0,32) 
call  cm.u_eq.constant.il (temp, 0,32) 
call  cm.logand.context.with.testO 

rank  -  CM.geometry .rank (source.geo) 
do  i«l, rank-1 

length  *  cmf _get_axis_extent(source,i-l) 
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call  CM_my_news_coordinate_lL(temp , i ,32) 
call  CM_u_lt_constant_ 1L (temp , length , 32) 
call  CM.logand.context.with.testO 
enddo 

call  cm.u.move.zero.alvays.lKsend.f ield,32) 
call  cm_s_8ubtract_constant_3_ll(il , index.l.id, 1 ,32) 
call  cm_s_subtract_constant_3_ll(i2, index_2_id, 1,32) 
caill  cm_s_subtract_constant_3_ll(i3 , index_3_id, 1 ,32) 
call  cm_deposit_news_coordinate_ll(dest_geo,8end_f ield, 1 , 

+  il ,32) 

call  cm_deposit_news_coordinate_ll(dest_geo,send_f ield, 2, 

+  i.2,32) 

call  cm_deposit_news_coordinate.il (dest.geo , send.f ield , 3 , 

+  i3 ,32) 

type  *  cmf_get_data_type(dest) 
elen  =  cmf .get.exponent.len(dest) 
slen  «  cmf_get_integer_len(dest) 

if  (type.eq.cmssl.float)  then 

call  cm_send_with_f_min.il (dest .id, send.f ield, source. id, 
+  23,8,cm_no_f ield) 

else  if  (type.eq.cmsal.s.integer)  then 

call  cm_send_with_s_min.il (dest.id, send.f ield, Bource. id, 
+  slen,cm_no_f ield) 

else  if  (type.eq.cmssl.u.integer)  then 

call  cm_send_with_u_min_ll (dest.id , send.f ield , source. id , 
+  slen,cm_no_f ield) 

else 

write  (*,*)  ’  ***  8catter_min_3:  bad  array  data  type’ 
endif 

call  cm_deallocate_stack_through(send_f ield) 
call  CHF_8et_is_modif ied(dest ,M0DIF) 
return 
end 


subroutine  scatter_max_3(dest , index. 1 , index_2 , index_3 .source) 
include  ’/usr/include/cm/paris-configuration-fort.h’ 
include  ’ /usr/ include/cm/ CMF.def s . h ’ 

c  compute  dest( index. l,index_2,index_3)  * 
c  max(dest(index_l,index_2,index_3) .source) 

c  sends  source  (n-dimensional)  to  dest  (3-dimensional) 
c 

c  parameters 

c  dest  :  real  destination  field; 3-dimensional 

c  index. 1  :  integer  field  ;  first  index  of  dest  array 

c  index_2  :  integer  field  ;  second  index  of  dest  array 
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c  index_3  :  integer  field  ;  third  index  of  dest  array 

c  source  :  real  source  field 

integer  dest , index. 1 , index_2 , index_3 .source 

integer  dest_id,index_l_id,index_2_id,index_3_id, source. id 
integer  sour ce.vp.set , dest. vp.set , dest. geo ,source_geo,send_f ield 
integer  length .temp , ii , i2 , i3 , rank , i 
integer  type.elen.slen 

dest.id  =  cmf .get.f ield.id(dest) 
index.l.id  =  cmf_get_field_id(index_l) 
index_2_id  =  cmf .get.f ield_id(index_2) 
index_3_id  =  cmf .get.f ield_id(index_3) 
source.id  *  cmf .get.f ield.id(source) 

if  (dest.id  .eq.  0)  then 
print  *, 

+ ’Error,  the  dest  argument  to  scatter_max_3  is  not  on  the  CM’ 
stop 
endif 

if  (index.l.id  .eq.  0)  then 
print  *, 

+’ Error,  the  index. 1  argument  to  scatter _max_3  is  not  on  the  CM’ 
stop 
endif 

if  (index_2_id  .eq.  0)  then 
print  *, 

+  * Error,  the  index_2  argument  to  scatter_max_3  is  not  on  the  CM’ 
stop 
endif 

if  (index_3_id  .eq.  0)  then 
print  * , . 

+’ Error,  the  index_3  argument  to  scatter _max_3  is  not  on  the  CM’ 
stop 
endif 

if  (source.id  .eq.  0)  then 
print  *, 

+  ’ Error,  the  source  argument  to  scatter_max_3  is  not  on  the  CM’ 
stop 
endif 

dest.vp.set  *  cmf _get_vp_set_id(dest) 
dest.geo  =  cm_vp_set_geometry(dest_vp_set) 
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source.vp.set  =  cmf _get_vp_set_id(source) 
source.geo  =  cm.vp.set.geometry (source.vp.set) 
call  cm_set_vp_set(source_vp_set) 

call  cm.set.contextO 

send_field  =  cm.allocate.stack.f ield(32) 
temp  =  cm.allocate.stack.f ield(32) 

11  *  cm.allocate.stack.f ield(32) 

12  *  cm_allocate_stack_f ield(32) 

13  =  cm_allocate_stack_f ield(32) 

call  cm_my_news_coordinate_ll(temp ,0 ,32) 
call  cir_u_eq_constant_ll(temp ,0 ,32) 
call  cm.logand.context.with.testO 

rank  =  CM_geometry_rank(source_geo) 
do  i=l, rank-1 

length  ■  cmf_g8t_axi8_extent(source,i-l) 
call  CM_my.news_coordinate_lL(temp ,i,32) 
call  CM_u_lt_con8tant_ 1L( temp , length , 32) 
call  CM.logand.context.with.testQ 
enddo 


call  cm.u.move.zero.always.  11  (send.f ield ,  32) 
call  cm_8_subtract_constant_3_ll(il ,index_l_id  1,32) 
call  cm_s_8ubtract_constant_3_ll(i2,index_2_id, 1 ,32) 
call  cm.s.subtract .constant _3_ 11 (i3, index_3_id, 1 ,32) 
call  cm.deposit.navs.coordinate.lKdest.geo, send.f ield, 1 , 

♦  il ,32) 

call  cm_deposit_news_coordinate.il (dest.geo , send.f ield , 2 , 

♦  i2,32) 

call  cm.deposit.nevB.coordinate.ll (dest.geo, send.f ield, 3, 

♦  13,32) 
type  ■  cmf _get_data_type(dest) 

elen  *  cmf_get_exponent_len(dest) 

8len  ■  cmf _get_integer_lsn(dest) 


if  (type.eq.cmssl.float)  then 

call  cm.send.with.f _max_ll(dest_id,8end_field,8ource_id, 
+  23,8,cm_no_f ield) 

else  if  (type.eq.cms8l_s_integer)  then 

call  cm_send_with_s_max_ll(dest_id, send.f ield.source.id, 
♦  8len,cm_no_f ield) 

else  if  (type.eq.cmssl.u.integer)  then 

call  cm_send_with.u_max_ll(dest_id,send_f ield, source. id, 
+  slen.cm.no.field) 
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else 

write  (*,*)  ’  ***  scatter_max_3 :  bad  array  data  type’ 
endif 

call  cm_deallocate_stadc_tfcrough(send_f ield) 
call  CMF_set_is_modif ied(dest ,MODIF) 
return 
end 
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B3  Sprint  Routines 


subroutine  begin_fast_array(array) 

integer  array 

call  transpose32 (array) 

return 

end 

subroutine  end_fast_ array (array) 

integer  array 

call  transpose32(array) 

return 

end 

subroutine  transpose32 (array) 

include  ’/usr/include/cm/paris-conf igur at ion-fort .h’ 
include  ’ /usr/include/cm/CMF_def s .h’ 

integer  array,  array.id,  array_vps,  array .geo,  array_type 

if  (CMF.get .home (array)  .eq.  HOME.CM.ONLY)  then 
print  *,  ’Error  in  transpose32,  arg  not  on  CM’ 
endif 

array. type  ■  CMF.get.data.type (array) 
array.id  *  CMF.get.f ield.id(array) 
array.vps  =  CMF_get_vp_8et_id(array) 
array _geo  =  CM_vp_set_geometry(array_vpB) 

if  ((array.type  .eq.  CMF.LOGICAL)  .or. 

+  (array.type  .  oq.  CMF.CDMPLEX)  .or. 

♦  (array.type  .eq.  CMF. CHARACTER)  .or. 

+  ((array.type  .eq.  CMF.FLOAT)  .and. 

♦  (CMF_get_significand_len(array)  .gt.  23)))  then 
print  *,  ’Error  in  transpose32,  arg  not  32  bits  long’ 

endif 

if  ((CM.geometry.axis.off .chip.bits (array _geo,  1)  .ne.  C)  .or. 

♦  (CM_geometry_axis_on_chip_bits( array _geo,  1)  .ne.  0))  then 
print  *,  ’Error  in  transpose32,  first  dimension  is  not  serial’ 

endif 

call  CM_set_vp_set(array_vps) 

call  CM_transpose32_l_lL(array_id,  32) 

call  CMF_set.is_modified(array ,  MODIF) 
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return 

end 

subroutine  fast.array.access (dest,  array,  index) 

include  ’ /usr/ include/cm/paris-conf iguration-f ort .h’ 
include  ’/usr/include/cm/CMF.defs.h’ 

integer  array , array. id , array. vps , array.geo , array.type , array.rank 
integer  dest,  dest.id,  dest.vps,  dest.geo,  dest.type,  dest.rank 
integer  index , index. id , index. vps , index.geo , index.type , index.rank 
integer  array.id.alias 
integer  temp.id 
integer  i 

if  (CMF.get.home(dest)  .eq.  HOME.CM.ONLY)  then 

print  *,  ’Error  in  fast.array .access,  arg  not  on  CM’ 
endif 

dest.type  =  CMF.get_data.type (dest) 
dest.id  *  CMF.get.field.id(dest) 
dest.vps  *  CMF_get_vp_set_id(dest) 
dest.geo  ■  CM. vp.set .geometry (dest.vps) 
dest.rank  =  CM_geometry_rank (dest.geo) 

if  ((dest.type  .eq.  CMF.LOGICAL)  .or. 

♦  (dest.type  .eq.  CMF.COMPLEX)  .or. 

+  (dest.type  .eq.  CMF.CHARACTER)  .or. 

♦  ((dest.type  .eq.  CMF.FLOAT)  .and. 

+  (CMF.get.signif icand.len(dest)  .gt.  23)))  then 

print  *,  ’Error  in  fast.array.access,  arg  not  32  bits  long’ 
endif 

if  (CMF_get_home( array)  .eq.  HOME.CM.ONLY)  then 

print  *,  ’Error  in  fast.array.access,  arg  not  on  CM’ 
endif 

array.type  =  CMF.get.data.type(array) 
array.id  *  CMF.get.f ield. id (array) 
array.vps  =  CMF_get_vp_set_id(array) 
array.geo  =  CM_vp_set_geometry(array_vps) 

if  (array.type  .ne.  dest.type)  then 
print  *, 

+  ’Error  in  fast.array.access,  array  not  same  type  as  dest’ 
endif 

if  ((CM.geometry_axis_off_chip.bits (array.geo,  1)  .ne.  0)  .or. 
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+  (CM_geometry_axis_on_chip_bits(array_geo,  1)  .ne.  0))  then 
print  *, 

+  'Error  in  fast_array_access ,  first  dimension  is  not  serial’ 
endif 

if  (CMF_get_home (index)  .eq.  H0ME_CM_0NLY)  then 

print  *,  'Error  in  fast_array_access,  arg  not  on  CM’ 
endif 

index.type  *  CMF_get_data_type( index) 
index.id  «  CMF_get_f ield_id(index) 
index.vps  «  CMF_get_vp_set_id(index) 
index.geo  *  CM_vp_set_geometry( index.vps) 
index.rank  =  CM_geometry_rank( index.geo) 

if  (index_vps  .ne.  dest.vps)  then 

print  *,  'Error  in  fast_array_access,  arrays  dont  conform’ 
endif 

if  ((index.type  .ne.  CMF.U.INTEGER)  .and. 

+  (index.type  .ne.  CMF_S_INTEGER) )  then 

print  *,  ’Error  in  fast.array.access,  index  not  integer’ 
endif 

call  CM_8et_vp_8et(index_vps) 
call  CM_set_context() 

temp.id  ■  CM.allocate.stack.f ield(32) 

call  CM_my_news_coordinate_lL(temp_id,  0,  32) 
call  CM_u_eq_constant_lL(temp_id,  0,  32) 
call  CM_logand_context _with_test ( ) 

do  i= 1 , index.rank- 1 

if  ((CM_geometry_axis_off_chip_bits(array_geo,  i+1)  .ne. 

+  CM.geometry.axis.off _chip_bits(index_geo,  i))  .or. 

+  (CM_geometry_axis_on_chip_bits(array_geo,  i+i)  .ne. 

+  CM_geometry_axis_on_chip_bits(index_geo,  i))  .or. 

+  (CM_geometry.axi8_off_chip.pos (array _geo,  i+1)  .ne. 

+  CM_geometry_axis_off_chip_pos(index_geo,  i))  .or. 

+  (CM_geometry_axi8_on_chip_pos (array _geo,  i+1)  .ne. 

+  CM_geometry_axis_on_chip_pos(index_geo,  i))  .or. 

+  (CMF_get_axi8_extent (array,  i)  .ne. 

+  CMF_get_axis_extent(index,  i-1))  .or. 

+  (CMF_get_axis_extent(dest,  i-1)  .ne. 

+  CMF_get_axis_extent(index,  i-1)))  then 

print  *,  ’Error  in  fast.array.access,  args  dont  conform' 
endif 
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+ 


call  CM_my_news_coordinate_lL(temp_id,  i,  32) 
call  CM_u_lt_constant_lL(temp_id, 

CMF_get_axis_extent(de8t,i-l) ,32) 
call  CM.logand.context.vith.testQ 
enddo 

array.id.alias  *  CM.make.f ield_alias( array. id) 

call  CM_u_subtract_constant_3_lL(temp_id,  index.id,  1,  32) 
call  CM_aref32_2L(dest.id,  ar r ay _id_ alias,  teop.id,  32,  32, 

+  CMF_get_axis_extent (array ,  1)) 

call  CM.remove.f ield_alias(array_id_  alias) 
call  CM_deallocate_stack_through(teinp_id) 
call  CMF_8et_is_modified(dest,  MODIF) 

return 

end 

subroutine  fast .array .update (array,  source,  index) 

include  ’ /usr/include/cm/paris-conf iguration-f ort .h’ 
include  ’ /usr/include/cm/CMF_def s .h* 

integer  array , array.id , array _vps , array _geo , array .type , array.rank 
integer  source,  source. id,  source. vps,  source_geo 
integer  source.type,  source.rank 

integer  index , index. id , index. vps , index.geo , index.type , index.rank 
integer  array.id. alias 
integer  temp.id 
integer  i 

if  (CMF.get .home (source)  .eq.  HOME.CM.ONLY)  then 

print  *,  ’Error  in  fast.array.update,  arg  not  on  CM* 
endif 

source.type  =  CHF_get_data_type(source) 
source. id  *  CMF.get.f ield.id(source) 
source_vp8  *=  CMF_get_vp_set_id(source) 
source.geo  *  CM_vp_set_geometry(source_vps) 
source.rank  *  CM.geometry.rank (source.geo) 

if  ((source.type  .eq.  CMF.LOGICAL)  .or. 

♦  (source.type  .eq.  CMF.COMPLEX)  .or. 

+  (source.type  .eq.  CMF. CHARACTER)  .or. 

+  ((source.type  .eq.  CMF. FLOAT)  .and. 

♦  (CMF.get. signif icand.len(source)  .gt.  23)))  then 

print  *,  ’Error  in  fast.array.update,  arg  not  32  bits  long’ 
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endif 


if  (CMF_get_home (array)  .eq.  HOME_CH_ONLY)  then 

print  *,  'Error  in  fast_array .update,  arg  not  on  CM’ 
endif 

array .type  ~  CMF_gct_data_type(array) 
array.id  *  CMF.get.f ield.id(array) 
array.vps  *  CMF_get_vp_set_id(array) 
array.geo  *  CM_vp_set_geometry(array_vps) 

if  (array .type  .ne.  source.type)  then 
print  *, 

+  'Error  in  fast.array .update,  array  not  same  type  as  source’ 
endif 

if  ((CM.geometry_axis_off_chip.bits (array.geo,  1)  .ne.  0)  .or. 

+  (CM_geometry_axis_on_chip_bits(array_geo,  1)  .ne.  0))  then 
print  *, 

+  'Error  in  fast.array .update,  first  dimension  is  not  serial’ 
endif 

if  (CHF_get_home( index)  .eq.  HOME.CM.ONLY)  then 

print  *,  'Error  in  fast.array .update,  arg  not  on  CM' 
endif 

index.type  ■  CMF.get.data.type(index) 
index.id  «  CMF.get.f ield. id (index) 
index.vps  “  CMF_get_vp_set_id(index) 
index.geo  «  CM_vp_set_geometry(index_vps) 
index.rank  ■  CM_geometry_rank( index.geo) 

if  (index.vps  .ne.  source. vps)  then 

print  *,  'Error  in  fast.array .update,  arrays  dont  conform’ 
endif 

if  ((index.type  .ne.  CMF.U. INTEGER)  .and. 

+  (index.type  .ne.  CMF.S. INTEGER))  then 

print  *,  'Error  in  fast.array .update,  index  not  integer’ 
endif 

call  CM_8et_vp_set( index.vps) 
call  CM.set.contextO 

temp.id  «  CM.allocate.stack.f ield(32) 

call  CM_my_news_coordinate_lL(temp_id,  0,  32) 
call  CM_u_eq_constant_lL(temp_id,  0,  32) 
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call  CM.logand.context.with.testO 
do  i=l,index_rank-l 

if  ((CM_geometry.axis_off_chip_bits(array_geo,  i+1)  .ne. 

+  CM_geometry_axis_off_chip_bits(index_geo,  i))  .or. 

+  (CM_geometry_axis_on_chip_bits(array_geo,  i+1)  .ne. 

+  CM_geometry_axis_on_chip.bits(index_geo,  i))  .or. 

-<■  (CM.gecsatry_axis.of f.chip.pcs (array.geo ,  i+1)  .ne. 

+  CM_.geometry_axis.off  _chip_pos(index_geo,  i))  .or. 

+  (CM_geometry_axis_on_chip_pos(array_geo,  i+1)  .ne. 

+  CM_geometry_axis_on_chip_pos(index_geo,  i))  .or. 

+  (CMF_get_axis_extent (array,  i)  .ne. 

+  CMF_get_axis_extent( index,  i-1))  .or. 

+  (CMF_get_axis_extent( source,  i-1)  .ne. 

+  CMF.get.axis.extent (index,  i-1)))  then 

print  *,  ’Error  in  fast_array_update,  args  dont  conform’ 
endif 

call  CM_my_news_coordinate_lL(temp_id,  i,  32) 
call  CM_u_rt_constant_lL(temp_id, 

+  CHF_get_axi8_extent(source,i-l) ,32) 

cadi  CM.logand.context.with.testO 
enddo 

array.id.alias  »  CM.make.f ield.alias(array.id) 

call  CM_u_subtract_ccnstant_3_lL(teinp_id,  index.id,  1,  32) 
call  CM_aset32_2L(8ource_id,  array_id_alias ,  temp.id,  32,  32, 

♦  CMF_get_axis_extent( array,  1)) 

call  CK_remove_field_alias(array_id_alias) 
call  CM_deallocate_stack_through(temp_id) 
call  CMF_set_i8_modified( array,  MODIF) 

return 

end 

subroutine  fast_array_access_2d(dest,  array,  inxl,  inx2) 

include  ’ /usr/include/cm/par is-conf igur at ion-f ort . h ’ 
include  ’/usr/ include/cm/ CMF.defs.h’ 

integer  array , array.id , array. vps , array.geo , array .type , array.rank 
integer  dest,  dest.id,  dest.vps,  dest.geo,  dest.type,  dest.rank 
integer  inxl , inxl.id , inxl.vps , inxl.geo , inxl .type, inxl .rank 
integer  inx2 , inx2.id , inx2_vps , inx2_geo , inx2.type , inx2_rank 
integer  array.id.alias 
integer  temp.id 
integer  i 
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integer  lenl,  len2 


if  (CMF.get.home(dest)  .eq.  HOME.CM.ONLY)  then 

print  *,  'Error  in  fast_array_acces8_2d,  arg  not  on  CM' 
endif 

dest.type  *  CMF.get.data.type(dest) 
dest.id  =  CMF.get.f ield.id(dest) 
dest.vps  ■  CMF_get_vp_set_id(dest) 
dest.geo  *  CM_vp_set_geometry(dest_vps) 
dest.rank  *  CM.geometry .rani (dest.geo) 

if  ((dest.type  .eq.  CMF.LOGICAL)  .or. 

+  (dest.type  .eq.  CMF.COMPLEX)  .or. 

+  (dest.type  .eq.  CMF.CHARACTER)  .or. 

+  ((dest.type  .eq.  CMF.FLOAT)  .and. 

♦  (CMF_get_significand_len(dest)  .gt.  23)))  then 

print  *,  'Error  in  f ast_array.access_2d,  arg  not  32  bits  long’ 
endif 

if  (CMF .get .home (array)  .eq.  HOME.CM.ONLY)  then 

print  *,  'Error  in  f ast_array_access_2d,  arg  not  on  CM’ 
endif 

array.type  *  CMF_get_data_type(array) 
array. id  *  CMF.get.f ield.id(array) 
array.vps  *  CMF_get_vp_set_id(array) 
array _geo  *  CM.vp.set .geometry (array.vps) 

if  (array.type  .ne.  dest.type)  then 
print  *, 

+  'Error  in  fast_array_access_2d,  array  not  same  type  as  dost’ 
endif 

if  ((CM.geometry.axis.off .chip.bits (array _geo,  1)  .ne.  0)  .or. 

+  (CM_geometry_axis_on_chip_bits(array_geo,  1)  .ne.  0))  then 
print  *, 

♦  'Error  in  fast_array_access_2d,  first  dimension  is  not  serial’ 
endif 

if  (CMF.get.home(inxl)  .eq.  HOME.CM.ONLY)  then 

print  *,  'Error  in  fast_array_access_2d,  arg  not  on  CM’ 
endif 

if  (CMF .get .home ( inx2)  .eq.  HOME.CM.ONLY)  then 

print  *,  'Error  in  f ast_array_access_2d,  arg  not  on  CM’ 
endif 
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inxl.type  ■  CMF_get_data_type(inxl) 
inx2_type  ■  CMF_get_data_type(inx2) 
inxl.id  *  CMF_get_f ield_id(inxl) 
inx2_id  *  CMF_get_f ield_id(inx2) 
inxl.vps  *  CMF_get_vp_8et_id(inxl) 
inx2_vps  *  CMF_get_vp_set_id(inx2) 
inxl_geo  *  CM_vp_set_geometry(inxl.vps) 
inx2_geo  -  CM_vp_set_geometry(inx2_vps) 
inxl.rank  «  CM_geometry_rank(inxl_geo) 
inx2_rank  ■  CM_geometry_rank(inx2_geo) 

if  (inxl.vps  .ne.  dest.vps)  then 

print  *,  ’Error  in  fast_array_acce88_2d,  arrays  dont  conform’ 
endif 

if  (inx2_vps  .ne.  dest.vps)  then 

print  *,  ’Error  in  f ast_array_accesB_2d,  arrays  dont  conform’ 
endif 

if  (( ini 1 .type  .ne.  CMF_U_INTEGER)  .and. 

+  (inxl.type  .ne.  CMF_S_ INTEGER))  then 

print  *,  'Error  in  f ast_array_access_2d,  inxl  not  integer’ 
endif 

if  ((inx2_type  .ne.  CMF_U_INTEGER)  .and. 

+  ( ini 2_ type  .ne.  CMF_S_ INTEGER))  then 

print  *,  ’Error  in  f ast_array_access_2d,  inx2  not  integer’ 
endif 

call  CH_8et_vp_8et(inxl_vps) 
call  CM_set_conteit() 

temp.id  «  CM_allocate_stack_f ield(32) 

call  CM_my_news_coordinate_lL(temp_id,  0,  32) 
call  CM_u_eq_constant_lL(temp_id,  0,  32) 
call  CM_logand_contert_sith_testO 

do  i*l , inxl_rank-l 

if  ((CH_geometry_axi8_off_chip_bitB(array_geo,  i+2)  .ne. 

+  CM_geometry_axis_off_chip_bits(inxi_geo,  i))  .or. 

♦  (CM_geemetry_axis_on_chip_bits(array_geo,  i+2)  .ne. 

♦  CM_geometry_aii8_on.chip_bits(inxi_geo,  i))  .or. 

+  (CM_geometry_axis_off_chip_pos (array _geo,  i+2)  .ne. 

+  CM_geometry_axis_off_chip_pos(inxi_geo,  i))  .or. 

+  (CM_geometry_axi8_on_chip_pos(array_geo,  i+2)  .ne. 

+  CM_geometry_axis_on_chip_pos(inxl_geo,  i))  .or. 

+  (CMF_get_axis_extent(array ,  i+1)  .ne. 
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+  CMF_get_axis_extent(inxl,  i-1))  .or. 

+  (CMF_get_axis_extent(dest,  i-1)  .ne. 

+  CMF_get_axis_extent(inxl ,  i-1)))  then 

print  *,  ’Error  in  fast.array_access.2d,  args  dont  conform’ 
endif 

call  CM^my.news.coordinate.lLCtemp.id,  i,  32) 
call  CM_u_lt_constant_lL(temp_id, 

+  CMF_get_axis_extent(dest,i-l) ,32) 

call  CM.logand.context.vith.testO 
enddo 

array.id.alias  =  CM.make.f ield.alias(array.id) 
lenl  «  CM_geometry_axis_length(array_geo, 1) 
len2  *=  CM_geometry_axis_length(array_geo,2) 

call  CM_u_subtract_constant_3_lL(temp_id,  inx2_id,  1,  32) 

call  CM_u_multiply_constant_2_lL(temp_id,  lenl,  32) 

call  CM_u_add_2.1L(temp_id,  inxl.id,  32) 

call  CM_u_subtract_con8tant_2_lL(temp_id,  1,  32) 

call  CM_aref32_2L(dest_id,  arr ay _id_ alias ,  temp.id,  32,  32, 

+  lenl*len2) 

call  CM_remove_f ield_alias(array_id_alias) 
call  CM_deallocate_stack_through<temp_id) 
call  CMF.set.is.modifiedCdest,  M0D1F) 

return 

end 

subroutine  f ast_array_update_2d(array,  source,  inxl,  inx2) 

include  ’ /usr/include/cm/par is- conf igurat ion-f ort . h ’ 
include  ’/usr/include/cm/CMF_defs.h’ 

integer  array , array.id , array. vps , array _geo , array.type , array.rank 
integer  source,  source.id,  source.vps,  source.geo 
integer  source.type,  source.rank 

integer  inxl , inxl .id, inxl. vps , inxl.geo , inxl .type , inxl.rank 
integer  inx2 , inx2_id , inx2_vps , inx2.geo , inx2_type , inx2_r ank 
integer  array .id. alias 
integer  temp.id 
integer  i 

integer  lenl,  len2 

if  (CMF.get.home(source)  .eq.  HOME.CM.ONLY)  then 

print  *,  ’Error  in  f ast_array_update_2d,  axg  not  on  CM’ 
endif 
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source.type  ■  CMF.get.data.type (source) 
source.id  =  CMF_get_f ield_id(source) 
source.vps  *  CMF_get_vp_Bet_id(source) 
source.geo  ■  CM_vp_set_geometry(source_vps) 
source.rank  =  CM_geometry_rank(source_geo) 

if  ((source.type  .eq.  CMF.LOGICAL)  .or. 

*■  (source.type  .eq.  CMF.COMPLEX)  .or. 

*  (source.type  .eq.  CMF.CHARACTER)  .or. 

*■  ((source.type  .eq.  CMF.FLOAT)  .and. 
f  (CMF_get_significand_len(source)  .gt.  23)))  then 

print  *,  ’Error  in  fast_array_update_2d,  arg  not  32  bits  long’ 
endif 

if  (CMF.get .home (array)  .eq.  HOME.CM.ONLY)  then 

print  *,  ’Error  in  f ast_array_update_2d,  arg  not  on  CM’ 
endif 

array.type  ■  CMF.get.data.type (array) 
array. id  ■  CMF.get.f ield.id(array) 
array _vps  *  CMF_get_vp_set_id(array) 

^ray-geo  *  CM_vp_aet_geometry(array_vps) 

if  (array .type  .ne.  source.type)  then 
print  *, 

h  ’Error  in  fast_array.update.2d,  array  not  same  type  as  Bource’ 
endif 

if  ((CM.geometry.aris.off _chip_bits(array_geo,  1)  .ne.  0)  .or. 

K  (CM.geometry_ari8_on_chip_bits(array_geo,  1)  .ne.  0))  then 
print  *, 

►  ’Error  in  f ast_array_update_2d,  first  dimension  is  not  serial’ 
endif 

if  (CMF.get .home ( inr 1 )  .eq.  HOME.CM.ONLY)  then 

print  *,  ’Error  in  fast.array_update.2d,  arg  not  on  CM’ 
endif 

if  (CMF .get .home ( inx2 )  .eq.  HOME.CM.ONLY)  then 

print  *,  ’Error  in  f ast_array_update_2d,  arg  not  on  CM’ 
endif 

inrl.type  *  CMF.get.data.type(inxl) 
inr2_type  ■  CMF.get_data.type(inx2) 
inrl.id  ■  CMF.get.f ield.id(inrl) 
inr2_id  *  CMF.get.f ield_id(inr2) 
inrl.vps  *  CMF_get_vp_set_id(inxl) 
inx2_vps  *  CMF_get_vp_set.id(inr2) 
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inxl.geo  *  CM_vp_set_geometry(inxl_vps) 
inx2_geo  »  CM.vp.set.geometry (inx2_vps) 
inxl.rank  =  CM.geometry.rank (inxl.geo) 
inx2_rank  =  CM_geometry_rank(inx2_geo) 

if  (inxl.vps  .ne.  source.vps)  then 

print  *,  ’Error  in  f ast_array_update_2d,  arrays  dont  conform’ 
endif 

if  (inx2_vps  .ne.  source.vps)  then 

print  *,  ’Error  in  f ast_array_update_2d,  arrays  dont  conform’ 
endif 

if  ((inxl.type  .ne.  CMF.U. INTEGER)  .and. 

+  (inxl.type  .ne.  CMF_S_INTEGER) )  then 

print  *,  ’Error  in  fast_array_update_2d,  inxl  not  integer* 
endif 

if  ((inx2_type  .ne.  CMF_U_ INTEGER)  .and. 

+  (inx2_type  .ne.  CMF_S_INTEGER))  then 

print  *,  ’Error  in  fast_array_update_2d,  inx2  not  integer’ 
endif 

call  CM_set_vp_set(inxl_vps) 
call  CM_set_context() 

temp.id  *  CM_allocate_8tack_f ield(32) 

call  CM_my_new8_coordinate_lL(temp_id,  0,  32) 
call  CM_u_eq_constant_lL(temp_id,  0,  32) 
call  CM_logand_context_with_test() 

do  i*l ,inxl_rank-l 

if  ((CM_geometry_axis_off_chip_bits (array _geo,  i+2)  .ne. 

+  CM_geometry_axis_off _chip_bits(inxl_geo,  i))  .or. 

♦  (CM_geometry_axis_on_chip_bit8(array_geo,  i+2)  .ne. 

+  CM_geometry_axis_on_chip_bits(inxl_geo,  i))  .or. 

+  (CM_geometry_axis_off.chip.poB(array_geo,  i+2)  .ne. 

♦  CM_geometry_axis_off_chip_pos(inxl_geo,  i))  .or. 

+  (CM_geometry_axi8_on_chip_po8 (array _geo,  i+2)  .ne. 

+  CM_geometry_axis_on_chip_pos(inxl_geo,  i))  .or. 

+  (CMF_get_axi8_extent(array ,  i+1)  .ne. 

+  CMF_get_axi8_extent(inxl,  i-1))  .or. 

+  (CMF .get_axi8.extent(source,  i-1)  .ne. 

+  CMF_get_axi8_extent(inxl ,  i-1)))  then 

print  *,  ’Error  in  f ast_array_update_2d,  args  dont  conform’ 
endif 

call  CM_my_news_coordinate_lL (temp.id,  i,  32) 
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call  CM_u_lt_constant_lL(temp_id, 

♦  CMF_get_axis_extent(source,i-l) ,32) 
call  CM_logand_context_vith_test() 

enddo 

array_id_alias  =  CM_make_f ield_ alias (array.id) 
lenl  =  CM_geometry_axis_length(array_geo, 1) 
len2  *  CM_geometry_axis_length(array_geo,2) 

call  CM_u_subtract_constant_3_lL(temp_id,  inx2_id,  1,  32) 
call  CM_u_multiply_constant_2_lL(teop_id,  lenl,  32) 
call  CM_u_add_2_lL(temp_id,  inxl.id,  32) 
call  CM_u_subtract_constant_2_lL(temp_id,  1,  32) 

call  CM_aset32_2L(80urce_id,  array. id.alias ,  temp.id,  32,  32, 

♦  lenl*len2) 

call  CM_remove_f ield_alias(array_id_alias) 
call  CM_deallocate_stack_through(temp_id) 
call  CMF_set_i8_modified(array ,  MODIF) 

return 

end 
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B4  Table  Lookup  Routines 


integer  function  make.integer.lookup (array ,  length) 
integer  array,  length 

include  ’ /usr/include/cm/paris-conf igurat ion-fort .h’ 
include  ’/usr/include/cm/CMF.defs.h* 

integer  result 

result  «  0 

call  _MAKE_INT_L00KUP (result ,  array,  length,  3) 
make.integer.lookup  =  result 

end  function  make.integer.lookup 


integer  function  make.real.lookup (array,  length) 
integer  array,  length 

include  ’/usr/include/cm/paris-conf iguration-fort .h’ 
include  ’ /usr/include/cm/CMF_def s . h  * 

integer  result 

result  ■  0 

call  _HAKE_REAL_L00KUP(rOi ult ,  array,  length,  4) 
make_real_ lookup  ■  result 

end  function  make .real .lookup 


integer  function  make. lookup. cm (cm. source. array , 

+  cm. index,  length,  cm.mask) 

integer  cm.source.array ,  cm. index,  length,  cm.mask 

include  ’ /usr/ include/cm/par is-conf igurat ion-f ort . h ’ 
include  ’/usr/include/cm/CMF.defs.h’ 

integer  result,  temp.index,  save.context,  rank.i 
integer  mask. id,  source.vp.set 
result  B  0 

source.vp.set  *  CMF_get_vp_8et_id(cm_B0urce_array) 
call  CM.set.vp.set (source.vp.set) 
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if  ((source_vp_8et  .ne. 

♦  CMF_get_vp_set_id(cm_source_array) )  .or. 

+  (source.vp.set  .ne.  CMF_get_vp_set_id(cm_index) )  .or. 

♦  ( source. vp.set  .ne.  CMF_get_vp_set_id(cm_mask)))  then 
print  *,  ’Arrays  do  not  c.11  belong  to  the  same  vp-set.  ’ 
return 

endif 

temp.index  =  CM_allocate_stack_field(32) 
save.context  «=  CM.allocate.stack.f ield(l) 
mask.id  =  CMF.GET.FIELD.ID (cm.mask) 

call  CM.sfore.context 'save.context) 
call  CM_set_context 

call  CM.load.context (mask.id) 
call  CK_my_news_coordinate_lL(temp_index,  0,  32) 
call  CM_u_le_constant_ll(temp_index,  0,  32) 
call  CM.logand_context_with.test 
do  rank_i=l ,  CM_geometry_rank( 

+  CM.vp.set.geometryCsource.vp.set))  -  1 
call  CM_my_news_coordinate_lL(temp_index,  rank.i,  32) 
call  CM_u_le_constant_ll(temp_index , 

+  CMF_get_axis_extent(cm_mask,  (rank.i  -  1)),  32) 
call  CM.logand_context_with.test 
enddo 

call  CM_store_context(mask_id) 

if  (CMF. GET_DATA_TYPE(cm_source_array)  ,eq. 

+  CMSSL.FLOAT)  then 

call  _MAKE.LOOKUP.CM (result,  CMF.GET. FIELD_ID( 

+  cm.source.array) ,  CMF_GET_FIELD_ID(cm_index) .length,  4, 

+  mask.id) 

else  if  ((CMF_GET_DATA_TYPE(cm_source_array)  .eq. 

CMSSL.U. INTEGER)  .or. 

+  (CMF_GET_DATA_TYPE(cm_source_array)  .eq. 

♦  CMSSL.S.INTEGER) )  then 

call  .MAKE.LOOKUP .CM (result,  CMF.GET. FIELD_ID( 

+  cm.source.array) ,  CMF_GET_FIELD_ID(cm_index) ,  length,  3, 
+  mask.id) 
else 

print  *,  ’IMPROPER  SOURCE  TYPE’ 
end  if 

call  CM.load. context (save.context) 

call  CM_deallocate_8tack_through( temp. index) 


135 


make.lookup.cm  =  result 


end  function  make. lookup. cm 

subroutine  free.lookup(lookup.table) 
integer  lookup.table 

include  * /usr/include/cm/paris-conf iguration-f ort .h’ 
include  ’/usr/include/cm/CMF.defs ,h’ 

call  .FREE.LOOKUP(lookup.table) 

return 

end 

subroutine  lookup(dest_cm_axray ,  lookup.table, 

+  index,  cm.mask) 
integer  lookup.table,  dest.element.type 
integer  index,  dest.cm. array 
integer  cm_mask 

include  ’ /usr/include/cm/paris-conf iguration-fort .h’ 
include  * /usr/ include/cm/CMF_def s . h ’ 

dest.element.type  *  CMF_get_data.type(dest_cm_array) 

call  .LOOKUP (CMF.get.f ield_id(dest_cm_ array) , 

+  lookup.table,  CMF.get.field.id(index) , 

♦  CMF.get.f ield. id (cm.mask) ,  dest.element.type) 

call  CMF_set_is_modif ied(dest_cm_ array ,M0DIF) 
return 
end 


•include  <stdio.h> 

•include  <cm/paris.h> 

•include  <cm/CMSS_object.h> 

struct  lut  {int  allocated.p;  int  size;  CM.f ield.id.t  cm.field;  int  field.type;}; 

typedef  struct  lut  lut.t; 

void  make.lookupO ; 
void  lookup 0; 
void  free.lookupO ; 

•if  def ined(8parc) 

•  define  MAKE.INT.LOOKUP  make.int.lookup. 
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#  define  MAKE. REAL. LOOKUP  make .real. lookup. 

#  define  MAKE.LOOKUP.CM  make .lookup. cm. 

#  define  FREE.LOOKUP  free.lookup. 

#  define  LOOKUP  lookup. 

#endif 

char  *malloc(); 

void  MAKE_INT_LOOKUP(lut .pointer,  array,  length,  lut.type) 
int  * array; 

int  *length,  *lut_type; 
lut.t  **lut .pointer;  { 
lut.t  *result; 
int  *  array. temp ; 

Ch.f ield.id.t  temp,  save.context ,  index; 

CM.vp.set.id.t  save.vp.set; 
int  i; 

array .temp  *  array; 

result  «  (lut.t  *)  malloc(sizeof (lut.t)) ; 
result->allocated_p  *  1; 

result->8ize  -  32  *  (1  +  (flength  -  1)  /  32); 

result->cm_f ield  «  CM_allocate_heap_field_vp_set(result->8ize,  CM.physical.vp.setO) 
reault->f ield.type  ■  *lut_type; 

save.vp.set  ■  CM.current.vp.set; 

CM.set.vp.set (CM.phy sical.vp.set ( ) ) ; 
temp  *  CM.allocate.stack.f ield(32) ; 
save.context  «  CM.allocate.stack.f ield(l) ; 
index  *  CM.allocate.stack.f ield( 16) ; 

CM_store_context(save_context) ; 

CM.set.contextO ; 

CM_s_move_zero_lL( index,  16); 

CM_my_8end_address_lL(temp) ; 

CM_8_eq_zero_lL(temp,  5); 

CM.logand.context.vith.testO ; 

for  (i»0;  i<*length;  array.temp+'O  { 
if  (*lut_type  3) 

CM_s_move_constant_lL(temp,  *array.temp,  32); 

CM_8_move_constant_lL(index,  i,  16); 

CM_aset32_shared_2L(temp,  result->cm_f ield,  index,  32,  16,  result->size) ; 
i  *  i  ♦  i;>; 

CM.load.context (save.context) ; 
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CM_deallocate_stack_through(temp) ; 
CM.set.vp.set (save.vp.set) ; 

*lut .pointer  ■  result; 


void  MAKE_REAL_LOOKUP(lut .pointer ,  array,  length,  lut.type) 
float  *array; 
int  ^length,  *lut_type; 
lut.t  **lut_pointer ;  { 
lut.t  *result; 
float  *array_temp; 

CM.f ield.id.t  temp,  save.context,  index; 

CM.vp.set.id.t  save.vp.set; 
int  i; 

array .temp  *  array; 

result  ■  (lut.t  *)  malloc(sizeof (lut.t)) ; 
result->allocated_p  =  1; 

result->size  «  32  *  (1  +  (^length  -  1)  /  32); 

re8ult->cm_f ield  *  CM.allocate.heap.f ield_vp.set(result->8ize,  CM.physical.vp.setO) ; 
result ->field_type  *  *lut_type; 

save.vp.set  ■  CM.current.vp.set ; 

CM_set_vp_set(CM_phyBical_vp_set()) ; 
temp  *  CM.allocate.stack.f ield(32) ; 
save.context  «  CM.allocate.stack.f ield(l) ; 
index  *  CM.allocate.stack.f ield(16) ; 

CM_8tore_context(save_context) ; 

CM.set.contextO ; 

CM_s_move_zero.lL (index,  16); 

CM.my.send.address.lKtemp) ; 

CM_8_eq_zero.lL (temp,  5); 

CM.logand.context.sith.testO ; 

for  (i*0;  i<*length;  array _temp++)  { 

CM.f _move_constant.lL (temp,  *array_temp,  23,  8); 

CM_s_move_constant_lL(index,  i,  16); 

CM.aset32_Bhared.2L (temp,  result->cm_field,  index,  32,  16,  result->size) ; 
i  *  i  ♦  i;>; 

CM.load. context (save.context) ; 

CM_deallocate_8tack_through(temp) ; 

CM_set_vp_set(save_vp_8et) ; 

*lut .pointer  ■  result; 
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void  MAKE_LOOKUP_CM(lut_pointer,  array,  cm.index,  length,  lut.type,  mash) 

CM_f ield_id_t  * array , *cm_ index , *mask ; 
int  *length,  *lut_type; 
lut.t  **lut .pointer;  •{ 
lut.t  *result; 

CM.f ield.id.t  save.context ,  index; 

CM.field.id_t  temp.index,  temp.news.coord; 

CM.vp.set.id.t  save.vp.set; 

save.context  =  CM.allocate.stack.f ield(l) ; 

CM.store.context (save.context) ; 
save.vp.set  =  CM.current.vp.set; 

CM_set_vp_set(CM_f ield_vp_set(*array)) ; 

result  *  (lut.t  *)  malloc(sizeof (lut.t)) ; 
result->allocated_p  *  1; 

result->size  ■  32  *  (1  ♦  (*length  -  1)  /  32); 
result->cm_f ield  *  CM_allocate_heap_field(result->size) ; 
result->field_type  *  ♦lut.type; 

temp.index  *  CM.allocate.stack.f ield(32) ; 

CM_load_context(*mask) ; 

CM_u_move_lL(temp_index, *cm_ index, 32) ; 

CM_u_subtract_constant_2_lL(temp_index, 1 ,32) ; 

CM_aset32_shared_2L(*array,  result->cm_field,  temp.index,  32,  16,  result->size) ; 
CM_spread_with_logior_lL(result->cm_f ield,  result->cm_field,  0,  32); 
CM_set_vp_8et(save_vp_set) ; 

CM.load.context (save.context) ; 

CM_deallocate_stack_through(save_context) ; 

♦lut.pointer  *  result; 


void  FREE.LOOKUP(lookup.table) 
lut.t  **lookup_table;  { 
if  ((**lookup_ta’  le) . allocated.p)  { 

CM.deallocate.heap.f ield((**lookup_table) .cm.f ield) ; 

(♦♦lookup.table) .allocated.p  *  0; 

> 

else 

printf ("free.lookup:  table  already  deallocated! \n") ; 

} 

void  LOOKUP (cm.f ield.id,  lookup.table,  cm.index.id,  cm.mask.id,  dest.element.type) 
lut.t  **lookup_table; 
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CM_f ield_id_t  *cm_f ield.id,  *cm_mask_id,  *cm_index_id; 
int  *dest_element_type;  { 

CM_f ield_id_t  save.context ,  temp_index_id; 

CM_vp_set_id_t  save„vp_set ; 

if  ((**lookup_table) .field.type  !*  *dest_element_type) 

{  if  (*dest_element_type  *«=  3) 

printf ("Lookup  table  not  allocated  as  an  integer!!  Instruction  failed. \n"); 
else 

{  if  (*dest_element_type  «  4) 

printf ( "Lookup  table  not  allocated  as  a  reed!!  Instruction  failed. \n"); 
else 

printf ("Destination  array  not  an  integer  or  real!!  Instruction  failed. \n"); 

» 

else  { 

save.context  *  CM_allocate_stack_f ield(l) ; 

CH_store_context(save_context) ; 
save.vp.set  *  CM_current_vp_set; 

CM_set_vp_set(CM_f ield_vp_set(*cm_field_id)) ; 
temp_index_id  *  CM_allocate_stack_field(16) ; 

CM_8et_context() ; 

CM_load_context (*cm_mask_id) ; 

CM_s_subtract_constant_3_lL(temp_index_id,  *cm_index_id,  1,  16); 

CM_invert_context() ; 

CM_e_move_zero_ 1L (temp_ index. id ,  16) ; 

CM_invert_context() ; 
if  ((**lookup_table) . allocated_p) 

CM_aref32_shared_2L(*cm_f ield.id,  (**lookup_table) .cm_field,  temp_index_id, 

32,  16,  (**lookup .table) .size) ; 
else 

printf ("Lookup  table  has  been  deallocated!  Instruction  f ailed. \n") ; 
CM_set_vp_set(save_vp_set) ; 

CM_load_context(Bave_context) ; 

CM_deallocate_stack_through(save_context) ; 

>; 

> 
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B5  Order  Routine 


subroutine  order  (dest, source, axis, mask) 

integer  dest 

real  source 

integer  axis 

integer  mask 

integer  temp, type, entry. vp.set 

include  '/usr/include/cm/paris-conf iguration-fort.h’ 
include  ' /usr/ include/cm/ CMF.def s .h* 

entry. vp_set  *  cm_current_vp_set() 

call  cm.set.vp.set  (cmf _get_vp_set_id(mask)) 

call  cm_load_context  (cmf .get.f ield.id(mask)) 

temp  *  cmf_get_f ield.id  (source) 

type  *  cmf _get.dat a.type  (source) 

if  (type  .eq.  cmssl_s_integer)  then 

call  cm_s_rank_2L(cmf .get.f ield.id(dest) .temp, axis, 
!  32, 32, cmf .upwards, cmf .none, 0) 

end  if 

if  (type  .eq.  cmssl.float)  then 

call  cm_f _rank_2L ( cmf .get _f ield.id ( dest ) .temp, axis, 
!  32,23,8,cmf_upwards,cmf_none,0) 

endif 

call  CMF_set_i8_modif ied(dest ,M0DIF) 
call  cm.set.vp.set  (entry.vp.set) 
end 
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B6  Scan  Routines 


subroutine  sum.scan (result,  source, dir, dim, sbit, mask) 
integer  result , source , dim .mask , sbit 
logical  dir 

include  ’/usr/include/ cm/par is -conf iguration-fort .h* 
include  ’ /usr/include/cm/CMF_def s .h* 
integer  scandir , length 

if  (dir)  then 

scandir  *  cm.upvard 
else 

scandir  *  cm.downward 
endif 

call  cm_set_vp_set  (cmf _get_vp_set_id(source)) 
call  cm_load_context(cmf .get.f ield.id(mask)) 
if  (cmf _get_data_type (result)  .eq.  cmf _s_ integer)  then 
call  cm_scan_with_8_add_ll  (cmf _get_f ield_id (result) , 
cmf .get.f ield.id(source) , 
dim, 

32, 

scandir, 
cm. inclusive, 
cm_8tart_bit , 
cmf_get_field_id(sbit)) 

endif 

if  ((cmf_get_data_type(result)  .eq.  cmf .float))  then 
call  cm_scan_with_f _add_ll  (cmf_get_f ield_id(result) , 
cmf _get_f ield_id(source) , 
dim, 

cmf_get_significand_len(source) , 

cmf_get_exponent_len(source) , 

scandir, 

cm. inclusive, 

cm. st art .bit , 

cmf .get.f ield.id(8bit)) 

endif 


if  ((cmf .get.data.type(result)  .eq.  cmf.complex))  then 
call  cm.scan.with.c.add.ll  (cmf.get.f ield.id(result) , 
cmf_get_field_id(source) , 
dim, 
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cmf .get.signif icand.len(source) , 

cmf _get_exponent_len(source) , 

scandir, 

cm. inclusive, 

cm.start.bit , 

cmf .get.f ield.id(sbit) ) 

endif 

call  cmf _set_is_modif ied(result ,MODIF) 

return 

end 

subroutine  product. scan(result,  source, dir, dim, sbit, mask) 
integer  result, source, dim, mask, sbit 
logical  dir 

include  ’/usr/include/cm/paris-conf iguration-fort .h’ 
include  ’/usr/include/cm/CMF.defs .h’ 
integer  scandir, length 

if  (dir)  then 

scandir  «  cm.upward 
else 

scandir  *  cm.downvard 
endif 

call  cm_set_vp_set  (cmf.get.vp.set.idCsource)) 
call  cm.load.context (cmf .get _f ield.id(mask) ) 

if  ((cmf _get.data.type (result)  .eq.  cmf .float))  then 

call  cm_scan_with_f_multiply.il  (cmf .get.f ield.id(result) , 
cmf .get.f ield.id(source) , 
dim, 

cmf_get_8ignif icand.len(source) , 

cmf_get_exponent_len(source) , 

scandir , 

cm. inclusive, 

cm. st art _b it , 

cmf .get.f ield.id(sbit)) 

else 

print  *,  'nrl-cmf-lib  scans:  integer  products  not  supported’ 
end  if 

call  cmf _8et_is_modif ied(result ,M0DIF) 

return 

end 


subroutine  max_scan(result,  source, dir, dim, sbit .mask) 
integer  result , source , dim .mask , sbit 
logical  dir 

include  * /usr/include/cm/par is-conf igur at ion-fort . h ’ 
include  ’/usr/include/cm/CMF.defs .h* 
integer  scandir, length 

if  (dir)  then 

scandir  =  cm.upvard 
else 

scandir  =  cm_ downward 
endif 

call  cm_set_vp_set  (cmf_get_vp_set_ id (source)) 
call  cm_load_context(cmf _get_f ield.id(mask)) 
if  (cmf_get_data_type (result)  .eq.  cmf.s.integer)  then 
call  cm_scan_with_s_max_ll  (cmf_get_field_id(result) , 
cmf  _get_f ield_id(source) , 
dim, 

32. 

scandir, 

cm_ inclusive , 

cm_start_bit , 

cmf _get_f ield_id(8bit) ) 


endif 

if  ((cmf _get_data_type (result)  .eq.  cmf.float))  then 
call  cm_scan_vith_f _mar_ll  (cmf.get.f ield.id(result) , 
cmf_get_f ield_id(source) , 
dim, 

cmf_get_signif icand_len(source) , 

cmf _get_exponent_len(source) , 

scandir, 

cm_ inclusive, 

cm_8tart_bit , 

cmf_get_f ield.id(sbit)) 

endif 

call  cmf _set_i8_modif ied(result ,M0DIF) 

return 

end 


subroutine  min_scan(result,  source, dir, dim, sbit .mask) 
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integer  result , source , dim .mask , sbit 
logical  dir 

include  ’ /usr/ include/ cm/paris-conf iguration-f ort ,h’ 
include  ’ /usr/include/ cm/ CMF.def s . h ’ 
integer  scandir .length 

if  (dir)  then 

scandir  =  cm.upward 
else 

scandir  =  cm_ downward 
endif 

call  cm_set_vp_set  (cmf_get_vp_set_id(source)) 
call  cm_load_context(cmf .get.f ield.id(mask)) 
if  ( cmf _get.data.type (result)  .eq.  cmf _s_ integer)  then 
call  cm_scan_with_s_min_ 11  (cmf_get_f ield_ id (result ) , 
cmf _get_f ield.id(source) , 
dim, 

32. 

scandir, 

cm. inclusive, 

cm_8tart_bit , 

cmf _get_f ield.id(sbit) ) 

endif 

if  ((cmf_get_data_type(result)  .eq.  cmf .float))  then 
call  cm_scan_with_f_min.il  (cmf_get_f ield_id(result) , 
cmf _get_f ield.id(source) , 
dim, 

cmf .get.signif icand.len(source) , 

cmf _get_exponent_len(source) , 

scandir, 

cm. inclusive, 

cm.start.bit , 

cmf_get_field_id(8bit)) 

endif 

call  cmf .set.is.modif ied (result ,M0DIF) 

return 

end 


subroutine  or_scan(result,  source, dir, dim, sbit, mask) 
integer  result , source , dim ,mask , sbit 
logical  dir 

include  ’/usr/include/cm/paris-conf iguration-f ort. h’ 
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include  ’/usr/include/cm/CMF.defs .h’ 
integer  scandir, length 


if  (dir)  then 

scandir  =  cm.upward 
else 

scandir  *  cm.dovnvard 
endif 

if  (cmf _get_data_type(result)  .eq.  cmf .logical)  then 
length* 1 
endif 

if  ( (cmf _get_data_type (result)  .eq.  cmf _u_integer)  .or. 
(cmf _get_data_type (result)  .eq.  cmf _s_ integer))  then 
length=32 
endif 

call  cm_set_vp_set  ( cmf _get_vp_set_ id (source)) 
call  cm_load_contert(cmf_get_field_id(mask)) 
call  cm_scan_with_logior_ll  (cmf _get_f ield_id(result) , 
cmf _get_field_ id (source) , 
dim, 
length, 
scandir, 
cm_ inclusive, 
cm_start_bit , 
cmf _get_f ield_id(sbit) ) 

call  cmf _8et_is_modif ied(result ,M0DIF) 

return 

end 


subroutine  xor.scan (result,  source, dir, dim, sbit, mask) 
integer  result , source , dim , mask , sb it 
logical  dir 

include  ’/usr/include/cm/paris-conf igurat ion-fort .h’ 
include  */usr/ include/cm/ CMF.defs.h’ 
integer  scandir .length 


if  (dir)  then 

scandir  =  cm.upward 
else 

scandir  *  cm.dovnward 
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endif 


if  (cmf .get.data.type(result)  .  eq.  cmf .logical)  then 
length= 1 
endif 

if  ((cmf _get.data.type (result)  .eq.  cmf _u_ integer)  .or. 

(cmf _get_data_type(result)  .eq.  cmf_s_integer))  then 
length=32 
endif 

call  cm.set.vp.set  (cmf _get_vp_set_id(source)) 
call  cm_load_context(cmf_get_field_id(mask)) 
call  cm_8can_with_logxor_ll  (cmf .get.f ield.id(result) , 
cmf_get_field_id(source) , 
dim, 
length, 
scandir , 
cm_ inclusive, 
cm_start_bit , 
cmf .get.f ield.id(sbit) ) 

call  cmf _set_is_modif ied(result ,MQDIF) 

return 

end 


subroutine  and_scan(result,  source, dir, dim, sbit, mask) 
integer  result , source , dim .mask , sbit 
logical  dir 

include  ’/usr/include/cm/paris-conf igurat ion-fort .h' 
include  ’/usr/include/cm/CMF.defs.h’ 
integer  scandir, length 


if  (dir)  then 

scandir  *  cm.upward 
else 

scandir  *  cm.downward 
endif 


if  (cmf_get_data_type(result)  .eq.  cmf .logical)  then 
length* 1 
endif 

if  ((cmf _get_data_type(result)  .eq.  cmf _u_ integer)  .or. 

!  (cmf .get.data.type(result)  .eq.  cmf _s_ integer))  then 
length* 32 
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endif 


call  cm_set.vp.set  (cmf .get. vp.set. id (source) ) 
call  cm_load_context(cmf .get.f ield.id(maBk)) 
cadi  cm_scan_sith_logand.il  (anf _get_f ield.id (result) , 
cmf_get_field_id(source) , 
dim, 
length, 
scandir , 
cm_ inclusive, 
cm_start_bit, 
cmf _get_f ield_id(sbit) ) 

call  cmf _set_is_modif ied(result ,M0DIF) 

return 

end 


subroutine  copy_scan(result,  source, dir, dim, sbit .mask) 
integer  x  esult , source , dim .mask , sbit 
logical  dir 

include  ’/usr/include/cm/paris-conf '  lration-fort.h* 
include  * /usr/include/cm/CMF_def s .h* 
integer  scandir .length 

if  (dir)  then 

scandir  ■  cm.upvard 
else 

scandir  *  cm.dosnsard 
endif 

if  (cmf .get.data.type(result)  .eq.  cmf.logical)  then 
length=l 
endif 

if  ((cmf_get_data_type(result)  .eq.  cmf _u_ integer)  .or. 

!  (cmf _get_data_tv  ^(result)  .eq.  cmf.s.integer))  then 
lengthB32 
endif 


if  (cmf.get.data_type(result)  .eq.  cmf .float)  then 
length  »cmf _get_significand_len(source)+ 
cmf _get_exponent_len(source)*l 

endif 
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if  (cmf .get.data.type(result)  .eq.  cmf .complex)  then 
length  «2* (cmf .get .significand.len (source)* 
cmf _get_exponent_len(source)+l) 

endif 

call  cm_set_vp_set  (cmf _get_vp_set_id(source)) 
call  cm_load_context(cmf .get .field. id(mask)) 
call  cm_scan_Hith_copy.il  (cmf .get.field.id(result) , 
cmf _get_field_id(sourco) , 
dim, 
length, 
scandir , 

^m_ inclusive, 
cm.start.bic, 
cmf .get.f ield.id(sbit) ) 

call  cmf_set_is_modified(result,MODIF) 

return 

end 
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B7  Framebuffer  Routines 


subroutine  init.fb (x.dim,  y_dim) 

include  ’/usr/include/cm/paris-conf igurat ion-fort .h’ 
include  ’/usr/include/cm/CMF.defs.h* 

common  /display.common/  my.geometry,  my.vp.set,  my_color, 
+  my.display,  ntsc.on 

integer  my.geometry,  my_vp_set,  my_color,  my.display 
integer  ntsc.on 

integer  x.dim,  y.dim 
integer  dims (2) 

CMF$  LAYOUT  DIHS( : SERIAL) 
integer  zoom 
logical  kludge (256 ,256) 
cmf$  layout  kludgeC :neus, :news) 

integer  physical.!,  physical.y,  foo 
character*10  a_null 

kludge  *.true. 
dims(l)  *  x.dim 
dims (2)  ■  y.dim 

my-geometry  »  CM_create_geometry(dims,  2) 
my.vp.set  *  CM_allocate.vp.set (my .geometry) 

call  _attach_fb(my_display,  ntsc.on) 
call  CMFB.initialize.display (my .display ,  8,  1) 
physical.!  *  CMFB.width(my.display) 
physical.y  =  CMFB.height(my.display) 
zoom  *  physical.!  /  x.dim 
if  (zoom  .gt.  physical.y/y.dim)  then 
zoom  =  physical.y  /  y.dim 
endif 

if  (zoom  .gt.  0)  then 
zoom  *  zoom  -  1 
endif 

call  CMFB_8et_zoom(my_display ,  zoom,  zoom,  0) 
if  (ntsc.on  .eq.  1)  then 

call  CMFB_set_pan(my .display ,  -32/ (zoom* 1) ,0) 
endif 

call  CM_set_vp_set(my_vp_8et) 

my.color  *  CM.allocate.heap.f ield(8) 

call  CM_u_move.zero_alvays_lL(my_color ,  8) 

return 

end 
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subroutine  plot_x_y(x,  y,  color,  mask) 
integer  x,  y,  color,  mask 

include  ’/usr/include/cm/paris-configuration-fort.h’ 
include  ’/usr/include/cm/CMF_defs ,h’ 

common  /display. common/  my .geometry,  my.vp.set,  my.color, 
+  my.display,  ntsc.on 

integer  my.geometry,  my.vp.set,  my.color,  my.display 
integer  ntsc.on 

integer  x.id,  y.id,  color.id,  mask. id,  rank.i 

integer  the .buffer 

integer  old.vp.set 

integer  a.send.address 

integer  temp. index 

x. id  *  CMF_get_f ield.id(x) 

y. id  ■  CMF_get_f ield.id(y) 
color.id  «  CMF.get.f ield.id(color) 
mask.id  *  CMF.get.f ield.id(mask) 
old.vp.set  *  CMF_get_vp.set_id(x) 

if  ((old.vp.set  .ne.  CMF_get_vp_set.id(y))  .or. 

+  (old.vp.set  .ne.  CMF_get_vp_set_id(color))  .or. 

+  (old.vp.set  .ne.  CMF_get_vp_set_id(mask)))  then 
print  *,  'Arrays  do  not  all  belong  to  the  same  vp-Bet.  ’ 
return 
endif 

call  CM.set.vp.set (my.vp.set) 
call  CM_u_move_zero_always_lL(my_color,  8) 
call  CM.set.vp.set (old.vp.set) 
call  CM.set.context 

temp .index  *  CM.allocate.stack.f ield(32) 
call  CM.load.context (mask.id) 

call  CM_my_news_coordinate_lL(temp_index,  0,  32) 
call  CM.u.l e_  const  ant  _ 1 1 ( t  emp  _ index ,  0,  32) 

call  CM.logand_context_with.test 
do  rank_i*l,  CM_geometry_rank( 

+  CM. vp.set .geometry (old.vp.set))  -  1 

call  CM_my_news_coordinate_lL(temp_index,  rank.i,  32) 
call  CM_u.le_constant_ll(temp_index, 

+  CMF_get_axis_extent(y ,  (rank.i  -  D),  32) 

call  CM.logand_context_with.test 
enddo 
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call  CM_deallocate_stack_through(temp_index) 

a_send_address  *  CM.allocate.stack.f ield(32) 

call  CMFB_shuffle_from_x_y(a_send_addre8s,  x_id,  y.id, 

+  my .geometry) 

call  CM_send_lL(my_color ,  a.send.address ,  color.id,  8, 

+  CM.no.f ield) 

call  CM_set_vp_set(my_vp_set) 
the.buffer  =  CMFB.spare.buff er(my.display) 
call  CMFB_vrite_preshuffled_always(my_di8play ,  the.buffer, 
+  my.color,  0,  0) 

call  CMFB_switch_buffer(my_display ,  the.buffer) 

call  CM_deallocate_stack_through(a_send_ address) 

call  CM.set.vp.set (old. vp.set) 

return 

end 


subroutine  plot_x_y_over(x,  y,  color,  mask) 
integer  x,  y,  color,  mask 

include  ’ /usr/include/cm/paris-conf iguration-f ort .h’ 
include  ’ /usr/include/cm/CMF_def s .h’ 

common  /display.common/  my .geometry,  my.vp.set,  my.color, 
+  my.display ,  ntsc.on 

integer  my .geometry,  my.vp.set,  my.color,  my.display 
integer  ntsc.on 

integer  x.id,  y.id,  color.id,  mask. id,  rank.i 

integer  the.buffer 

integer  old.vp.set 

integer  a_send.address 

integer  temp.index 

x. id  *  CMF_get.f ield.id(x) 

y. id  «  CMF.get.field.id(y) 
color.id  *  CMF.get.f ield.id(color) 
mask.id  *  CMF.get.field.id(mask) 
old.vp.set  *  CMF_get_vp_set_id(x) 

if  ((old.vp.set  .ne.  CMF_get_vp_set_id(y))  .or. 

+  (old.vp.set  .ne.  CMF.get.vp.set.id(color))  .or. 

+  (old.vp.set  .ne.  CMF_get_vp_set_id(mask)))  then 
print  *,  ’Arrays  do  not  all  belong  to  the  same  vp-set.  ’ 
return 


152 


endif 


call  CM_set_vp_set(old_vp_set) 
call  CM.set.context 

temp.index  =  CM.allocate.stack.f ield(32) 
call  CM_load_context(mask_id) 

call  CM_my_nees_coordinate_lL(temp_index,  0,  32) 
call  CM_u_le_constant.il (temp.index,  0,  32) 
call  CM.logand_context_with.test 
do  rank_i=l,  CM.geometry.rank ( 

♦  CM_vp_8et_geometry(old_vp_set))  -  1 

call  CM_my_news_coordinate.lL (temp. index,  rahk.i,  32) 
call  CM.u.le. const ant. 11 (temp. index , 

+  CMF.get_axis_exte»t(y,  (rank.i  -  1)),  32) 

call  CM.logand_context.eith.te8t 
enddo 

call  CM_deallocate_stack_through(temp_index) 

a.send.address  ■  CM.allocate.stack.f ield(32) 

call  CMFB_8huffle_from_x_y(a_send_addres8,  x.id,  y.id, 

+  my.geometry) 

call  CM_8end.lL (my .color,  a.send.address,  color.id,  8, 

♦  CM.no.field) 

call  CM_set_vp_8et(my_vp_set) 

the.buffer  *  CMFB.spare.buffer (my .display) 

call  CMFB.write.preshuf fled. always (my.display,  the.buffer, 

♦  my.color,  0,  0) 

call  CMFB_8witch_buffer(my_display,  the.buffer) 

call  CM.deallocatG_8tack_through(a_send_addre8s) 

call  CM.8et_vp_set(old_vp_8et) 

return 

end 


subroutine  release.frame.bufferO 

include  ’ /usr/include/cm/paris-conf iguration-fort .h' 
include  1 /usr/include/cm/CMF.def s .h’ 

common  /display.common/  my .geometry,  my.vp.set,  my.color, 
+  my.display,  ntsc.on 

integer  my.geometry,  my.vp.set,  my.color,  my.display 
integer  ntsc.on 

call  CMFB.detach.display (my.display) 
call  CM_deallocate_heap_field(my_color) 
call  CM.deallocate.vp.set (my.vp.set) 
call  CM.deallocate.geometry (my.geometry) 
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return 

end 


subroutine  set_color(color_id,  red,  green,  blue) 
integer  color.id,  red,  green,  blue 

include  ’ /usr/ include/ cm/paris -conf iguration-f ort . h ’ 
include  ’ /usr/include/cm/CMF_def a .fa ’ 

common  /display.common/  my .geometry,  my.vp.set,  my. color, 

♦  my.display ,  ntsc.on 

integer  my.geometry,  my.vp.set,  my_color,  my.display 
integer  ntsc.on 

call  CMFB.write.color (my .display,  CMFB.red,  color.id,  red) 
call  CMFB.write.color (my.display,  CMFB.green,  color.id,  green) 
call  CMFB.write.color (my. display,  CMFB.blue,  color.id,  blue) 
return 
end 


subroutine  plot_from.gr id (color) 
integer  color 

include  ' /usr/include/cm/paris-conf iguration-f ort .h’ 
include  ’ /usr / include/cm/ CMF.def s . fa ’ 

common  /display.common/  my.geomi  y,  my.vp.set,  my.color, 
+  my.display,  ntsc.on 

integer  my.geometry,  my.vp.set,  my.color,  my.display 
integer  ntsc.on 

integer  geometry.old,  geometry .new 
integer  dimensions (2) 
integer  color.id 
integer  the.buffer 
integer  color. vp.set.id 

color.id  *  CMF.get.field.id(color) 
color.vp.set.id  ■  CMF_get_vp_set_id(color) 

dimensions (1)  ■  CM.geometry.axis.length 

♦  (CM_vp_set_geometry(color_vp_set_id) ,  1) 
dimensions (2)  ■  CM.geometry.axis.length 

♦  (CM.vp.set.geometry  (color.vp.set.id) ,  2) 

geometry.old  »  CM. vp_set_geometry(color_ vp.set.id) 
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geometry .new  *  CM.intern.geometry (dimensions,  2) 

call  CM.set.vp.set.geometry (color. vp_set_id,geometry_new) 

the.buffer  =  CMFB_spare_buffer(my_display) 

call  CMFB.write.always (my .display,  the.buffer,  color.id,  0,  0) 
call  CM.set.context  () 

call  CMFB.switch.buff er (my.display ,  the.buffer) 

call  CM_set_vp.set_geometry(color_vp_8et_id,  geometry.old) 

return 

end 


•include  <cm/paris.h> 

•include  <cm/cmfb.h> 

•if  definedCsparc) 

•  define  ATTACH.FB  attach. fb_ 

•endif 

char  ♦getenvO ; 

void  ATTACH.FB (display,  ntsc.on) 

CMFB.display.id.t  ^display; 
int  •ntsc.on; 

{ 

char  *  fb.type; 

♦ntsc.on  *  0; 

•display  *  CMFB_attach_display(getenv("CM_FRAMEBUFFER") ,  0) ; 
fb.type  -  getenvC'CM.FB.MODE") ; 
if  (fb.type  **  ! strcmp (fb.type ,  "NTSC"))  { 

•ntsc.on  ■  1; 

CMFB_set_monitor.id(*display ,  CMFB.ntsc) ; 

> 

> 
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B8  Plot  Routines 


c  this  is  a  general  purpose  routine  for  using 
c  paris  from  cmf.  it  sets  vp  set  and  the  context 

c  to  reflect  the  processor  configuration  in  array  'x* 

c 

subroutine  configure (x) 
integer  x 
integer  address, i 

include  * /usr/include/cm/ paris-conf igurat ion-f ort . h  * 
include  ’/usr/include/cm/CMF.defs.h’ 

call  cm_set_vp_set  (cmf _get_vp_set_id(x) ) 

call  cm.set.contextO 

address  *  cm_allocate_stack_field(32) 

call  GB_my_news_coordinate.il  (address ,0,32) 

call  cm.u.eq.constant. 11 ( address , 0,32) 

call  cm_logand_context_with_test() 

do  2  i*l,cmf_get_rank(l) 

call  cm_my_news_coordinate.il  (address, i, 32) 

call  cm_u_lt_con8tant_ll(addre8B,cmf_get_axis_extent(l,i-l) ,32) 
call  cm_logand_context_with_test() 

2  continue 

call  cm_deallocate_stack_ through  (address) 
end 

subroutine  openplO 

common  /scale.common/  sxO.syO.sxl.syl 

read  sxO.syO.sxl.syl 

sx0=0. 0 

8x1*1024.0 

sy0*0 . 0 

8yl*1024.0 

call  init_fb( 1024, 1024) 
cadi  _attach( 1024, 1024) 
end 

subroutine  closeplO 
call  release.frame.bufferO 
cadi  .detach () 
end 

subroutine  erase () 

common  /display.common/  my .geometry ,my_vp_set,my_color,my_display 
integer  my.geometry,  my.vp.set,  my.color,  my.display 
cadi  .clear (my.color) 
end 
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subroutine  set_text_size(x) 
integer  x 

call  _set_font_number(x) 
end 

subroutine  space(xl,yltx2,y2) 
real  xl.yl.x2.y2 

common  /scale.common/  sxO.syO.sxl.syl 

real  sxO.syO.sxl ,syl 

sxO=xl 

syO=yl 

sxl*x2 

syl«y2 

end 

subroutine  scale (x.y) 

include  * /us r/ include/ cm/par i s - conf igur at i on -f ort . h ’ 

include  ’/usr/include/cm/CMF.defs.h’ 

integer  x.y 

real  plot _x, ploy _y 

common  /scale.common/  sxO.syO.sxl.syl 
real  sxO.syO.sxl.syl 

common  /display.common/  my .geometry .my.vp.set, my .color .my.display 
integer  my.geometry,  my.vp.set,  my .color,  my .display 

plot.x  *  real(cm_geometry_axis_langth(my.geometry,0)) 
plot.y  ■  real(cm_geometry_axis_length(my_geometry,l)) 
if  ((8x0  .eq.  0.0)  .and.  (sxl  .eq.  0.0)  .and.  (syl  .eq.  0.0) 

!  .and.  (syO  .eq.  0.0))  then 
sx0=0. 0 
sy0=0.0 
8Xl=pl0t_X 

syl=plot_y 

endif 

call  CM_f_8ubtract_constant_2.lL  (x.dble(sxO) ,23,8) 

call  CM_f_8ubtract_con8tant_2.lL  (y.dble(syO) ,23,8) 

call  CM_f_multiply_con8tant_2.lL  (x, dble (plot.x/ (sxl-sxO)) ,23,8) 

call  CM_f_multiply_con8tant_2.lL  (y,dble(plot_y/(syl-syO)) ,23,8) 

end 

subroutine  lines  (xl,yl,x2,y2, color, mask) 

include  '/usr/include/cm/paris-conf iguration-fort ,h’ 

include  ' /usr/include/cm/CMF.defs.h’ 

common  /display.common/  my.geometry .my.vp.set .my.color .my.display 

real  xl.yl.x2.y2 
integer  color 
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logical  mask 
integer  entry_vp_set 
integer  sx3,sy3,sx4,sy4 

entry_vp_set  =  an_current_vp_set ( ) 
cedi  configure  (mask) 

call  cm_logand_context(cmf .get.f ield.id(mask)) 
sx3  *  cm_allocate_stack_field(32) 
sy3  *  cm_allocate_stack_field(32) 

8x4  *  cm.allocate.stack.f ield(32) 
sy4  *  cm.allocate.stack.f ield(32) 
call  cm_u_move.il  (sx3,cmf .get.f ield.id(xl) ,32) 
call  cm_u_move.il  (sy3,cmf .get.f ield.id(yl) ,32) 
call  cm_u_move.il  (sx4,cmf .get.f ield_id(x2) ,32) 
call  cm_u_move.il  (sy4,cmf .get.f ield_id(y2) ,32) 
call  scale(sx3,sy3) 
call  scale(sx4,sy4) 

call  .plot.lines  (my .color, sx3,sy3,sx4,sy4, 
cmf .get.f ield.id(color) ) 
call  _ref resh_fb(my_display ,my_color) 
call  cm.deallocate.stack.through  (sx3) 
call  cm_set_vp_8et  (entry.vp.set) 
end 

subr out ine  1 ine ( x 1 , y 1 , x2 , y2 , color ) 
real  xl,yl,x2,y2 
integer  color 

real  cxl(l) ,cyl(l) ,cx2(l) ,cy2(l) 

integer  ccolor(l) 

logical  ma8k(l) 

cxl  *xl 

cyl  *yl 

cx2  *x2 

cy2  *y2 

ccolor*color 

mask* . true . 

call  1 ines ( cx 1 , cy 1 , cx2 , cy 2 , ccolor , mask ) 
end 

subroutine  circles  (x,y,r, color, mask) 

include  ’ /usr /include/cm/par is - conf igur at ion-f ort . h ’ 

include  ’ /usr/include/cm/CMF_def s . h ’ 

common  /display.common/  my .geometry , my. vp_set,my_color,my_display 

real  x,y,r 
integer  color 
logical  mask 
integer  entry.vp.set 


158 


integer  sx.sy 


entry_vp_set  *  cm_current_vp_set() 
call  configure  (mask) 

call  cm_logand_context(cmf _get_f ield.id(mask) ) 
sx  =  cm_allocate_stack_f ield(32) 
sy  =  cm_allocate_stack_f ield(32) 
call  cm_u_move_ll  (sx.cmf _get_f ield_id(x) ,32) 
call  cm_u_move_ll  (sy ,cmf_get_field_id(y) ,32) 
call  scale(sx,sy) 

call  _plot_circles  (my.color, sx.sy , 

cmf_get_field_id(r) ,  cmf_get_field_id(color)) 
call  _refresh_fb(my_di8play ,my_color) 
call  cm_deallocate_stack_through  (sx) 
call  cm_set_vp_set  (entry .vp.set) 
end 

subroutine  circle(x,y ,r, color) 

real  x,y,r 

integer  color 

real  cx(l) ,cy(l) ,cr(l) 

integer  ccolor(l) 

logical  mask(l) 

cx  *x 

cy  -y 

cr  *r 

ccolor  »color 
mask*1,  true. 

call  circles (cx , cy , cr , ccolor .mask) 
end 

subroutine  points  (x,y .color .mask) 

include  ’ /usr/include/cm/paris-conf iguration-f ort .h’ 
include  * /usr/include/cm/ CMF.def 8 . h ' 

common  /display_common/  my .geometry ,my_vp_set,my_color,my_display 

real  x.y 
integer  color 
integer  mask 
integer  entry.vp.set 
integer  sx.sy 

entry .vp.set  ■  cm_current_vp_set () 

call  configure (mask) 

sx  *  cm_allocate_8tack_f ield(32) 

sy  ■  cm.allocate.stack.f ield(32) 

call  cm_u_move.lL  (sx.cmf _get_field_id(x) ,32) 

call  cm_u_move.lL  (sy ,cmf _get_f ield.id(y) ,32) 
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call  scale(sx,sy) 

call  cm_logand_context(cmf_get_field_id(mask)) 

call  _plot_point  (my.color ,sx,sy ,cmf_get_field_id(color)) 

call  .refresh.fb (my. display, my.color) 

call  cm_deallocate_stack_through(sx) 

call  cm.set.vp.set  (entry.vp.set) 

end 

c  should  be  reimplemented  to  use  cm.u.write.to.processor 
subroutine  point (xfy .color) 
real  x.y 
integer  color 
real  cx(l),cy(l) 
integer  ccolor(l) .mask(l) 
cx  «x 
cy  «y 

ccolor  “color 
mask*l 

call  points(cx,cy, ccolor, mask) 
end 

subrout ine  label ( s , lien , x , y , color) 

include  '/usr/include/cm/paris-conf igurat ion-fort .h* 

include  ’ /usr/include/cm/CMF_def s .h’ 

character*255  s 

integer  lien 

real  x.y 

integer  color 

common  /display_common/  my .geometry ,my_vp_set, my .color, my_display 

integer  my .geometry,  my.vp.set,  my.color,  my.display 

common  /scale.common/  sxO,syO,sxl,syl 

real  sxO,syO,sxl,syl 

read  plot_x,plot_y 

plot.x  *  real(cm.geometry.axis.length(my_geometry,0)) 
plot.y  *  real(cm_geometry_axi8_length(my .geometry, 1) ) 
if  ((sxO  .eq.  0.0)  .and.  <sxl  .eq.  0.0)  .and.  (syl  .eq.  0.0) 

!  .and.  (syO  .eq.  0.0))  then 
sx0=0 . 0 
8y0=0.0 
sxl*plot_x 
syl*plot_y 
endif 

plot.x  *  (x-sx0)*(plot.x/(sxl-sx0)) 
plot.y  *  (y-syO) * (plot.y/ (syl-syO)) 

call  _print_string(my_color , lien , s .plot.x .plot.y , color) 

call  _ref resh_fb(my_display .my.color) 

end 
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subroutine  set _color_value (color , r , g ,b) 

integer  color, r,g,b 

cedi  set.color  (color ,r,g,b) 

end 


•include  <an/cnfb.h> 

•include  <an/paris.h> 

•if  def ined(sparc) 

•  define  SET.FONT.NUMBER  set_font_number_ 

•  define  CLEAR  clear. 

•  define  ATTACH  attach. 

»  define  REFRESH.FB  refresh.fb. 

•  define  PLOT.POINT  plot.point. 

»  define  PLOT.LINES  plot.lines. 

•  define  PLOT.CIRCLES  plot.circles. 

•  define  DETACH  detach. 

•  define  PRINT.STRING  print.string. 

•endif 

•define  COORD.LEN  32 
•define  COLOR.LEN  8 
•define  TEXT.SPACING  5 
•define  lines.dimensions  32768 
•define  xp.size  (128+COLOR.LEN) 

•define  circle.zp.size  (96+COLOR.LEN) 

•define  VREF(x,y)  ((CM.field_id_t)CM_add.offset_to_field_id((unsigned)x,32*y)) 

void  _CMI.scan_with_f_add.ld  0; 

struct  font  { 
char  ^memory; 

unsigned  char.x.size.char.y.size; 
char  *widths; 

>; 

static  float  x_constant,y. constant; 

static  struct  font  *plot_font; 

static  CM.field.id.t  constant.!; 

static  CM.field.id.t  constant.y; 

static  CM_vp_8et_id_t  lines. vp_set*0; 

static  struct  CM.geometry.id  *lines_geometry ; 
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extern  struct  font  fontsD; 


vc id  CM_u_f_truncate_l_lL(source,s ,e) 

CM_f ield_id_t  source; 
unsigned  s,e; 

{ 

CM.f ield.id.t  s_dest  *  CM.allocate.stack.f ield  (s+e+1); 

CM.s.f _truncate_2_2L(s_dest,  source,  s+e+i,  s,e); 
CM_u_move_lL  (source, s.dest, s+e) ; 
CM.deallocate.stack.through  (s.dest) ; 

> 

void  SET.FONT.NUMBER(size) 
int  *size; 

{ 

plot.font  =  *(fonts[*size]) ; 

> 

void  CLEAR(plot_f ield) 

CM.f ield.id.t  *plot_field; 

{ 

CM.vp.set.id.t  entry_vp_set  *  CM_current_vp_set ; 
CM_set_vp_set(CM_f ield. vp_set(*plot_f ield) ) ; 
CM_u_move.constant.lL  (*plot_f ield,0,C0L0R_LEN) ; 
CM.set.vp.set (entry. vp.set) ; 

} 

void  ATTACH(x.y) 
int  *x,*y; 

{ 

int  start.font  *2; 
unsigned  dimensions [2] ; 

dimensions [0] =lines_dimensions ; 
lines.geometry  =CM_create_geometry (dimensions ,1) ; 
lines.vp.set  ■  CM_allocate_vp_set  (lines.geometry) ; 
SET_FONT_NUMBER(Jtstart_font) ; 

> 

void  check. vp.set  (plot.field) 

CM.f ield. rd.t  *plot_field; 

{ 

if  (lines.vp.set  *=  0) 

ATTACH (CM.geometry. axis .length  (CM.vp.set.geometry 
(CM.f ield. vp_set(*plot_f ield)) ,0) , 
CM.geometry_axi8_length  (CM.vp.set.geometry 
(CM_field_vp_8et(*plot_field)) ,1)) ; 
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> 


void  REFRESH. FB(plot_display, plot.f ield) 
struct  CHFB.display.id  **plot_display ; 

CM.f ield.id.t  *plot_field; 

{ 

CM.vp.set.id.t  entry.vp.set  ■  CM.current.vp.set; 

CM.set_vp.set  (CM.f ield_vp_set(*plot_f ield) ) ; 

CMFB.write.preshuf f led.always  (*plot_display , 

CMFB_spare_buffer(*plot_display) , 

♦plot.f ield ,0,0) ; 

CMFB_switch_buffer(*plot_display .CMFB.spare.buff er(*plot_display)) ; 
CM_set.vp.set  (entry.vp.set); 

> 

void  PL0T.P0INT (plot.f ield , x , y , color) 

CM.f ield.id.t  *plot_f ield , *x , *y , *color ; 

< 

CM.f ield.id.t  address  *  CM.allocate.stack.f ield  (21); 

CM.f ield.id.t  entry.context  *  CM.allocate.stack.f ield(l) ; 

CM.f ield.id.t  tx*CM_allocate_stack_f ield  (11); 

CM.f ield_id_t  ty«CM_allocate_stack_f ield  (11); 
unsigned  plot.x  ■  CM.geometry.axis.length  (CM.vp.set.geometry 
( CM.f ield. vp_set(*plot .field)) ,0) ; 
unsigned  plot.y  «  CM.geometry.axis.length  (CM.vp.set.geometry 
(CM_f ield. vp_set(*plot_ field)) ,1) ; 

check. vp.set  (plot.f ield) ; 

CM.store.context(entry.context) ; 

CM.f _lt_constant.lL  (*x, (float)plot_x,23,8) ; 

CM.logand. context _sith_test() ; 

CM_f_ge_constant.lL  (*x, 0.0, 23, 8) ; 

CM.logand.context.with.testO ; 

CM.f _lt_con8tant.lL  (*y,(float)plot_y,23,8) ; 

CM.logand.context.with.testO ; 

CM.f _ge_constant.lL  (*y ,0.0,23,8) ; 

CM.logand.context.with.testO ; 

CM.u_f_round.2_2L  (tx,*x, 11 ,23,8) ; 

CM.u_f_round.2_2L  (ty,*y, 11,23,8) ; 

CMFB_shuffle_from_x_y  (address,tx,ty, 

CM. vp.set.geometry (CM.f ield. vp.set (*plot .field))) ; 

CM.send. IL  (*plot_f ield , address , *color .COLOR.LEN , (CM.f ield.id.t ) CM.no.f ield) ; 
CM.load.context  (entry.context) ; 

CM.deallocate.stack.through  (address) ; 

> 

void  compute.linear.patch  (dest.this.point, next .point, t) 

CM.f ield.id.t  dest , this.point ,next_point , t ; 
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{ 

CM.f _subtract_3_lL  (dest .next.point .this.point ,23 ,8) ; 
CM_f_multiply_2.lL  (dest, t, 23, 8) ; 

CM_f _add_2_lL  (dest, this.point, 23, 8) ; 

> 

void  pixels  (dest,xl,yl,x2,y2) 

CM_field_id_t  dest ,xl ,yl ,x2,y2; 

{ 

CM.f ield.id.t  temp  =  CM.allocate.stack.field  (32); 
CM_f_subtract_3_lL  (temp.xl ,x2,23,8) ; 

CM_f_subtract_3.lL  (dest,yl,y2,23,8) ; 

CM_f _abs_l_lL  (temp, 23, 8); 

CM.f _abs_l.lL  (dest, 23, 8); 

CM.f _max_2_lL  (dest, temp, 23, 8) ; 

CM.deallocate.stack.through  (temp) ; 

> 

void  PLOT_LINES(plot_field,xl ,yl ,x2 ,y2, color) 

CM_f ield_id_t  *plot_f ield , *xl , *y 1 , *x2 , *y2 , *color ; 

{ 

CM.vp.set.id.t  entry_vp_set  *  CM.current.vp.set; 

CM.f ield.id.t  xp , result , temp , temp2 , seg .unknown , address .temp ; 

CM.f ield.id.t  entry_context“CM_allocate_stack_f ield  (1); 
CM_field_id_t  address=CM_allocate_stack_f ield  (32); 

CM.f ield.id.t  procs_needed=CM_allocate_8tack_field(32) ; 

CM.f ield.id.t  other  *  CM.allocate.stack.f ield  (32); 
unsigned  total.procs.needed , i , iterations ; 
float  old.xh; 

/♦initialize  line.vp.set*/ 

CM.set.vp.set  (lines_vp_set) ; 
xp=CM_allocate_stack_f ield  (xp.size) ; 
addre8S_temp  =  VREF(xp,4); 
temp*CM_allocate_stack_f ield  (32) ; 
temp2*CM_allocate_stack_field(32) ; 
unknown  *  CM.allocate.stack.f ield(32) ; 
seg=CM_allocate_stack_f ield  (1); 

CM_u_move..zero_always_  1L  (seg ,  1 ) ; 

CM.set.vp.set  (entry. vp.set) ; 

CM.store.context  (entry. context) ; 
pixels (procs.needed , *xl , *y 1 , *x2 , *y2) ; 

_CMI_scan_with_f .add. Id  (address .procs.needed ,CM_send_order ,23,8, 
CM.upward , CM .inclusive , CM.none ,0) ; 
total.procs.needed  *  CM.global.f _max.lL  (address, 23, 8) 
iterations  =  (unsigned)  total.procs.needed/lines.dimens-  ns; 
CM_f_8ubtract_2.lL  (address, procs.needed, 23, 8) ; 
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CM_u_f .truncate. 1_1L  (address ,23 ,8) ; 

CM_make_news_coordinate_lL  (lines.geometry , other, 0, address, 32) ; 
for  (i=0;i<=iterations;i+-O{ 

CM_u_ge_constant_lL  (address , i*line8_dimensions ,32) ; 
CM_logand_context_with_test  (); 

CM_u_lt_constant_lL  (address, (i+l)*lines_dimensions, 32) ; 
CM_logand_context_with_test  (); 

CM_send_lL  (xp.othej  ,*xl ,32, (CM_f ield_id_t)CM_no_f ield) ; 

CM_send_lL  (VREF(xp! 1) .other ,*yl ,32 , (CM_field_id_t)CM_no_f ield) ; 

CM_send_lL  (VREF(xp,2) , other, *x2, 32, (CM_f ield_id_t)CH_no_f ield) ; 

CM_send.lL  (VREF(xp,3) , other, *y2, 32, (CM.f ield_id_t)CM_no_f ield) ; 

CM_send_lL  (VREF(xp,4) ,  other,  *color,C0L0R,_LEN,  seg) ; 

CM_set_vp_set  (lines_vp_set) ; 

CM.set.contextO ; 

CM_f_move_constant_lL  (temp2, 1.0,23,8) ; 
if  (i  !«  0)  { 

unsigned  zero  =  CM.fe.make.news. coordinate (lines .geometry ,0,0) ; 
CM.clear.context  (); 

CM_u_write_to_processor.lL  (zero, CM.context.f lag, 1,1) ; 
if  (CM_u_read_from_processor_lL  (zero,seg,l)  **  0)  { 

CM.f .write.to.processor.lL  (zero,temp2,old_xh,23,8) ; 

CM.get.from.news.lL  (xp ,xp ,0,CM_downward,xp_size) ; 

CM_u_write_to_processor_ 1L  (zero , seg ,1,1); 

> 

CM.set.context  (); 

> 

CM.scan.with.copy _ 1L  (xp , xp , 0 , xp_s ize , CM.upward , CM_ inclusive , 
CM_start_bit,seg) ; 

CM.scan.with.f .add. 1L  (temp , t emp2 ,0,23,8, CM.upward , CM_ inclusive , 
CM.start.bit , seg) ; 

old.xh  =CM_f_read_from_processor_lL  ( 

CM.f e.make.news.coordinate 

(lines .geometry ,0,lines_dimensions-l) , 

temp, 23, 8) ; 

if  (i==iterations){ 

CH_my_new8_coordinate.lL  (temp2,0,32) ; 

CM_u_lt_conatant.lL  (temp2, (unsigned) (total.procs.neededXlines.dimensions) 
.32); 

CM_logand_context.with.test  (); 

> 

pixels  (temp2,xp,VREF(xp,l) ,VREF(xp,2) ,VREF(xp,3)) ; 

CM_f_divide_2.lL  (temp,temp2,23,8) ; 
compute.linear.patch  (temp2,xp,VREF(xp,2) .temp) ; 
compute.linear .patch  (unknown, VREF(xp,l) ,VREF(xp,3) ,temp) ; 

PLOT.POINT (plot.f ield , &temp2 , ^unknown , ftaddress.temp) ; 
CM_u_move_zero_always_lL  (seg,l); 

CM.set. vp.set  (entry.vp.set) ; 

CM.load.context  (entry.context) ; 
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> 

> 


void  PLOT.CIRCLES (plot.f ield , x , y , r , color) 

CM_f ield.id.t  *plot_f ield , *x , *y , *r , *color ; 

{ 

CM_vp_set_id_t  entry.vp.set  =  CM.current.vp.set ; 

CM_f ield_ id_ t  xp , result , temp , temp2 ,  seg , unknown ; 

CM_f ield_id_t  entry_context=CM_allocate_stack_f ield  (1); 

CM.f ield.id.t  address=CM_allocate_stack_f ield  (32); 

CM_f ield_id_t  procs_needed=CM_allocate_stack_f ield(32) ; 

CM_f ield_id_t  other  *  CM_allocate_stack_f ield  (32); 
unsigned  total.procs .needed , i , iterations ; 
float  old.xh; 

check_vp_set(  plot.f ield) ; 

/♦initialize  line.vp.set*/ 

CM.set.vp.set  (lines.vp.set) ; 
xp=CM_allocate_stack_f ield  (circle.xp.size) ; 
temp=CM_allocate_stack_f ield  (32) ; 
temp2*CM_allocate_stack_f ield(32) ; 
unknown  ■  VREF(xp,3); 
seg=CM_allocate_stack_f ield  (1); 

CM.u_move_zero_always_iL  (seg.l); 

CM.set.vp.set  (entry.vp.set) ; 

CM.store.cortext  (entry.context) ; 

CM_f_multiply_constant_3.lL  (procs_needed,*r, 3. 1415926,23,8) ; 
_CMI.scan_with_f_add.ld  (address, procs_needed,CM_send_order ,23,8, 
CM.upward , CM. inclusive , CM.none , 0) ; 
total.procs.needed  *  CM_global_f_max.lL  (address, 23, 8) ; 
iterations  *  (unsigned)  total.procs.needed/lines.dimensions ; 
CM_f_subtract_2.lL  (address .procs.needed, 23 ,8) ; 

CM.u.f .truncate. 1_1L  (address, 23 ,8) ; 

CM.make.news.coordinate. 1L  (lines.geometry , other , 0 , address , 32) ; 
for  (i=0;i<=iterations;i++){ 

CM_u_ge_constant.lL  (address, i*lines_dimens ions, 32) ; 
CM_logand_context_with_test  (); 

CM_u_lt_constant.lL  (address, (i+l)*lines_dimensions, 32) ; 
CM_logand_context_with_test  (); 

CM_send.lL  (xp, other, *x, 32, (CM.f ield_id_t)CM_no_f ield) ; 
CM_send.lL  (VREF(xp, 1) .other ,*y, 32, (CM.f ield_id_t)CM_no_f ield) ; 
CM_send_lL  (VREF(xp,2) , other, *r ,32, (CM.f ield_id_t)CM_no_f ield) ; 
CM_8end.lL  (VREF(xp,3) , other, *color,COLOR_LEN, seg) ; 

CM.set.vp.set  (lines.vp.set); 

CM.set.contextO  ; 

CM_f_move_constant.lL  (temp2,1.0,23,8) ; 
if  (i  ! *  0)  { 
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unsigned  zero  =  CM_fe_make_nevs_cocrdinate(lines_geometry ,0,0) ; 
CM.clear.context  (); 

CM_u_write_to_processor_lL  (zero, CM.context.f lag, 1,1); 
if  (CM_u_read_from_processor_lL  (zero,seg,l)  ■*  0)  { 

CM.f _write_to_processor_lL  (zero,temp2,old_xh,23,8) ; 

CM_get_from_news.lL  (xp,xp,0,CM_downward,circle_xp_size) ; 
CM_u_write_to_processor_lL  (zero ,seg, 1 , 1) ; 

> 

CM_set_context  (); 

> 

CM_scan_with_copy.lL  (xp,xp,0,circle.xp.size,CM_upward, CM. inclusive, 
CM_start_bit,seg) ; 

CM_scan_vith_f _add_ 1L  (temp , temp2 ,0,23,8, CM.upward , CM. inclusive , 
CM_start_bit , seg) ; 

old.xh  *CM_f_read_from_processor_lL  ( 

CM.fe.make.news.coordinate 
(lines_geometry ,0, lines. dimensions- 1) , 
temp, 23, 8) ; 
if  (i==iterations){ 

CM.my.news.coordinate.lL  (temp2,0,32) ; 

CM_u_lt_constant_lL  (temp2,  (unsigned)  (total_proc8_needed'/,line8_dimen8ions) 
.32); 

CM_logand_context_with_test  (); 

> 

CM_f _multiply_con8tant_3_lL  (temp2,VREF(xp,2) ,3.1415926,23,8) ; 
CM_f_divide_2_lL  (temp,temp2,23,8) ; 

CM_f .multiply .constant _2_1L  (temp, 2*3. 1415926,23,8)  ; 

CM_f_8in_2.lL  (temp2,temp,23,8) ; 

CM.f.cos.I.lL  (temp, 23, 8); 

CM.f .multiply _2_1L  (temp2 ,VREF(xp,2) ,23,8) ; 

CM_f .multiply _2_1L  (temp,VREF(xp,2) ,23,8) ; 

CM_f_add_2_lL  (temp2,xp,23,8) ; 

CM_f_add_2_lL  (temp,VREF(xp,l) ,23,8) ; 

PLOT.POINT (plot _f  ield ,  4temp2 ,  ftt emp ,  Jtunknown)  ; 

CM.u.move.zero.always.lL  (seg.l) ; 

CM.set.vp.set  (entry.vp.set) ; 

CM.load.context  (entry.context) ; 

> 

CM.deallocate.stack.through  (entry.context) ; 

> 

void  DETACH 0 

{ 

CM.deallocate.vp.set  (lines.vp.set) ; 

CM.deallocate.geometry  (lines.geometry) ; 

> 

unsigned  font.value  (char_value,x,y) 
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unsigned  char_value,x,y; 

{ 

unsigned  index* (char_value-32)*plot_font->char_x_size+x+ 
(y*plot_font->char_x_size*96) ; 
unsigned  byte  *  index/8; 
unsigned  bit  *  index'/,8; 

unsigned  char  result  =plot_f ont->memory [byte] ; 
result  *  (result  >>  bit)  £  1; 
return  result; 

> 

*if  def ined(sparc) 

struct  ftn.string  {char  str[255]>; 

ielse 

struct  ftn_string  {short  len;  char  *  str>; 
tendif 

void  PRINT_STRING(plot_f ield , length , string , xp , yp , color) 

CM_f ield_id_t  *plot_field; 
int  * length; 

struct  ftn.string  *string; 
float  *xp,*yp; 
int  *color; 

{ 

unsigned  plot.x  *  CM_geometry_axis_length  (CM.vp.set.geometry 
(CM_field_vp_set(*plot.field)) ,0) ; 
unsigned  plot.y  *  CM.geometry.axis.length  (CM_vp_set_geometry 
(CM.f ield_vp_set(*plot_field)) ,1) ; 
int  k*0,temp.x.constant=(int) (*xp) ,xd,yd,ipx,y ,c; 
unsigned  address; 

CM.vp_set.id_t  entry_vp_set  *  CM.current.vp.set; 
check. vp.set  (plot.f ield) ; 

CM.set.vp.bdt  (CM_field_vp_set(*plot_field)) ; 
for  (i=0;i<*length;i++){ 
c*string->str[i] ; 

for(x*0;x< (plot.f ont->sidths) [c-32] ;x*+) 
for  (y*0;y<(plot_font->char_y_8ize)  ;y+-0{ 
xd  *  x+temp_x_constant; 
yd  *  y+(int)(*yp) ; 

if  (font_value(c,x,y)tt(xd>0)ft£(yd>0)t4(xd<plot_x)*Jt(yd<plot_y)){ 
address  ■  CMFB.f e.shuff le.from.x.y  (xd,yd, 

CM.vp.set .geometry 

(CM.f ield. vp.set (*plot_f ield) ) ) ; 

CM.u.write.to.processor. 1L ( address , *plot _f ield , *color , COLOR.LEN) ; 


> 

temp.x.constant  ♦=  x; 


> 


B9  Surface  Routines 


c 

c  this  is  a  general  purpose  routine  for  using 
c  paris  from  cmf.  it  sets  vp  set  and  the  context 

c  to  reflect  the  processor  configuration  in  array  *x’ 

c 

subroutine  configure(x) 
integer  x 
integer  address, i 

include  ’/usr/include/cm/paris-conf igur at ion-fort .h’ 
include  ’ /usr/ include/ cm/CMF_def s . h  * 

call  cm_set_vp_set  (cmf _get_vp_set_id(x)) 

call  cm.set.contextQ 

address  *  cm_allocate_stack_f ield(32) 

call  cm_my_news_coordinate.il  (address, 0,32) 

call  cm_u_eq_constant_ 11 (address ,0,32) 

call  cm.logand.context.with.testO 

do  i*l,cmf_get_rank(x) 

call  cm_my_news_coordinate_ll  (address, i, 32) 

call  cm.u.lt.constant. 11 (address, cmf _get_axis_extent(x,i-l) ,32) 
call  cm.logand.context.with.testO 
enddo 

call  cm.deallocate.stack.through  (address) 
end 

subroutine  surface  (z, color, theta, phi) 
real  z, theta, phi 
integer  color 

include  ’/usr/include/cm/paris-conf iguration-fort .h’ 
include  ’ /usr/ include/cm/CMF_def s .h’ 

common  /display.common/  my .geometry,  my.vp.set,  my.color, 

+  my.display 

integer  my.geometry,  my.vp.set,  my.color,  my.display 
call  configure(z) 

call  _8urface_internal  (my.color , cmf .get.f ield.id(z) , 
t  cmf .get.field.id(color) , 

t  theta, phi, 1, my.display) 

return 
end 

subroutine  surface.over  (z, color, theta, phi) 
real  z, theta, phi 
integer  color 

include  ’/usr/include/cm/paris-conf iguration-fort .h’ 
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include  ’ /usr/include/cm/ CMF.def s .h * 

common  /display_common/  my .geometry,  my.vp.set,  my.color, 
+  my.display 

integer  my.geometry,  my.vp.set,  my.color,  my.display 


call  configure (z) 

call  .surface. interned  (my.color ,cmf_get_f ield.id(z) , 
t  cmf .get.f ield.id(color) , 

t  theta, phi, 0, my.display) 

return 
end 

subroutine  shade  (dest,z,lx,ly ,lz) 

integer  dest 

real  x,y ,z,lx,ly ,lz 

include  ’/usr/include/cm/paris-conf iguration-fort .h’ 
include  ' /usr/ include/cm/CMF_def s . h ’ 
call  configure  (dest) 

call  .light.intensity  (cmf .get.f ield.id(dest) , 
t  cmf .get.f ield_id(z) , lx, ly,lz) 

return 
end 


•include  <cm/paris.h> 

•include  <cm/cmfb.h> 

•include  <cm/cmfs.h> 

•include  <cm/cm_f ile.h> 

•include  <math.h> 

•include  <stdio.h> 

•if  def ined(sparc) 

•  define  LIGHT.INTENSITY  light.intensity. 

•  define  SURFACE. INTERNAL  surface. internal. 

•endif 

•define  AMBIENT  60 

•define  COLOR.DEPTH  8 

void  rotate.constant  (x,y, angle) 

CM.field.id.t  x,y; 
float  angle; 

{ 

CM.field.id.t  temp  *  CM.allocate.stack.f ield  (32); 
float  s«sin(angle) ,c=cos(angle) ; 

CM_u_move.lL  (temp, x, 32); 

CM.f _multiply_constant_2_lL  (x,c,23,8) ; 
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CM.f _mult_const_add.lL  (x.y, (-s) ,x,23,8) ; 
CM_f _multiply_con8tant_2_lL  (y,c,23,8) ; 
CM.f .mult _const_add.lL  (y ,temp,s,y,23,8) ; 
CM.deallocate.stack.through  (temp) ; 

> 


void  SURFACE. INTERNAL  (dest.z, color, theta, phi, erase.p, display) 

CM.field.id.t  *dest ,*z,*color; 
float  *theta,*phi; 
unsigned  *erase_p; 
struct  CMFB_display_id  **display; 

{ 

CM.field.id.t  x , y , shade , temp , address .message , buff er , seg ,mz ; 

CM_vp_set_id_t  o_vp_set  *  CH_current_vp_set ; 

CM.vp_set.id_t  b_vp_set  ■  CM_field_vp_set(*dest) ; 
unsigned  dimensions [3] ,buffer_d[2] .zoom; 
unsigned  message.length , coord.length ; 

dimensions [0] =1 ; 

dimensions[l]*!CM_geometry_axis_length(CM_vp_set_geometry(o_vp_set) , 1) ; 
dimensions [2] =CM_geometry_axis_length(CM_vp_set_geometry(o_vp_8et) ,2) ; 
buffer_d[0]*CM_geometry_axis_length(CM_vp_set.geometry(b_vp_set) ,0) ; 
buffer_d[l]*CM_geometry_axis_length(CM_vp_set_geometry(b_vp_Bet) ,1) ; 
zoom  ■  1024/buffer_d[0]-l; 

if  ((buffer_d[0]  !*  dimensions [1] *2) I | 

(buffer_d[l]  !■  dimensions [2] *2) ){ 

fprintf  (stderr, "surface  dimensions  are  incompatible  with  framebuffer"); 
exit(l) ; 

> 

coord_length=CM_geometry_coordinate_length  (CM_vp_set_geometry(b_vp_set) ,1) ; 

message.length  *  COLOR.DEPTH  +  coord.length; 

message  ■  CM.allocate.stack.f ield  (message.length); 

x  *  CM_allocate_stack_field(32) ; 

y  «  CM.allocate.stack.f ield(32) ; 

mz  =  CM.allocate.stack.f ield(32) ; 

shade  »  CM.allocate.stack.f ield(32) ; 

address  *  CM.allocate.stack.f ield(32) ; 

seg  ■  CM.allocate.stack.f ield(l) ; 

CM.set.vp.set  (b.vp.set) ; 

buffer  »  CM_allocate_stack.field(message_length) ; 

CM_u.move_zero_always.lL  (buffer .message.length) ; 
if  (*erase_p«l) 

CM_u.move_zero_always.lL  (*dest,8) ; 

CM_set_vp_set(o_vp_set) ; 
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CM_u_move_ 1L  (mz , *z , 32) ; 

CM_u_move_zero_lL  (seg,l); 

CM.my.nevs.coordinate.lL  (shade, 1,32) ; 

CM_u_le_constant_lL  (shade, 3, 32) ; 

CM_logior_2_lL  (seg,CM_test_flag,l) ; 

CM_u_ge_constant.lL  (shade, dimensions [1] -3, 32) ; 

CM_logior_2_lL  (seg,CM_test_flag,l) ; 

CM_f_u_float_2_2L  (x, shade, 32, 23, 8) ; 

CM_my_news_coordinate.lL  (shade, 2, 32) ; 

CM_u_move_lL  (CM_add_off set_to_field_id(message,COLOR_DEPTH) , 
shade , coord.length) ; 

CM_u_le_constant_lL  (shade, 3, 32) ; 

CM_logior_2_lL  (seg,CM_test_flag,l) ; 

CM_u_ge_constant_lL  (shade, dimensions [2] -3, 32) ; 

CM_logior_2_lL  (seg,CM_test_flag,l) ; 

CM.f_u_float.2_2L  (y , shade ,32,23,8); 

CM_f_subtract_constant_2.lL  (x, (float)dimensions[l]/2.0,23,8) ; 

CM_f _subtract_constant_2_lL  (y, (f loat) dimensions [2] /2. 0,23, 8) ; 
CM_u_moTe.lL  (message, *color, 8) ; 

CM_load_context(seg) ; 

CM_u_move_zero_ 1L  (message , COLOR.DEPTH) ; 

CM_set_context() ; 
rotate_constant  (x,y,-(*theta)) ; 

CM_f _add_constant.3_ 1L  (shade , y , (float) buff er.d [1 ] /2 . 0 , 23 , 8) ; 
CM_u_f_round_2_2L  (message+C0L0R_DEPTH,shade,coord_length,23,8) ; 
rotate.constant  (y,mz,*phi); 

CM_f _add_constant_2_lL  (x, (float ) buff er.d [0]/2. 0,23, 8) ; 
CM_f_add_constant_2_lL  (y , (float)buffer_d[l]/2.0,23,8) ; 

CM_u_f_round_2_2L  (shade,x,coord_length,23,8) ; 

CM_maie_new8_coordinate.lL  (CM. vp.set .geometry (b.vp.set) , address, 0, 
shade ,coord_length) ; 

CM.u.f _round_2.2L  (shade,y,coord_length,23,8) ; 

CM_deposit_nev8_coordinate.lL  (CM_vp_set_geometry(b_vp_set) .address, 1, 
shade, coord.length) ; 

CM_8end_with_u_max.lL (buffer , address .message ,message.length,CM_no.f ield) ; 
CM.set.vp.set (b.vp.set) ; 

CM_scan_with_u_max.lL  (buffer, buffer ^.message.length, 

CM.upward,  CM_inclusive,CM_none,CM_no_field) ; 

CM_u.gt_zero.lL (buffer, 8) ; 

CM_logand_context_with_test() ; 

CMFB.preshuffle.f or .write  (*dest, buffer, 8) ; 

CMFB_write_preshuffled_alway8  (*display,CMFB_spare_buffer(*display) , 

*dest ,0,0) ; 

CM.set.contextO ; 

CMFB.8witch.buffer(*display ,CMFB_spare_buffer(*display)) ; 
CM.deallocate.stack.through  (message) ; 
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> 


void  smooth.float. image  (image) 

CM_f ield_id_t  image; 

{ 

CM_f ield_id_t  temp  =  CM.allocate.stack.f ield(32) ; 

CM_f ield_id_t  temp2  =  CM.allocate.stack.f ield(32) ; 

CM_f _move_zero.lL  (temp, 23, 8); 

CM.f _newB_add_always_2.lL  (temp,image,0,CM_upward,23,8) ; 
CM_f _new8_add_always_2_ 1L  (temp , image , 1 , CM.upward ,23,8); 
CM_f_news_add_always_2_lL  (temp,image,0,CM_downward,23,8) ; 
CN_f_ne08_add_alway8_2.lL  (temp,image,l,CM_downward,23,8) ; 
CM_f _add_2_lL  (image, temp, 23, 8) ; 

CM_f _divide_constant_2_lL  (image, 5. 0,23, 8) ; 
CM_deallocate_stack_through  (temp) ; 

> 


void  LIGHT.INTENSITY  (deat,o2,rz,rx) 

CM.f ield.id.t  *dest,*oz; 
float  *rz,*rx; 

{ 

CM_f ield.id.t  gx  ■  CM.allocate.stack.f ield(96) ; 
CM_field_id_t  gy  *  CH_add_offset_to_field_id(gx,32) ; 
CM_field_id_t  gz  *  CM_add_offset_to_f ield_id(gy ,32) ; 
CM_f ield.id.t  x  *  CM.allocate.stack.f ield(32) ; 

CM.f ield.id.t  y  «=  CM.allocate.atack.f ield(32) ; 

CM.f ield.id.t  z  ■  CM.allocate.stack.f ield(32) ; 

CM.f ield.id.t  norm  ■  CM.allocate.stack.f ield(32) ; 
float  min, max; 

CM.my.news.coordinate.lL  (z,l,32) ; 

CM_f_u.float.2_2L  (x,z,32,23,8) ; 

CM.f _Bubtract_con8tant_2.lL 

(x, (f loat)CM_geometry_axis_length 
(CM_vp_aet_geometry(CM_current_vp_set) ,l)/2.0,23,8) ; 
CM.my.news.coordinate.lL  (z,2,32); 

CM.f _u_f loat_2_2L  (y ,z,32,23,8) ; 

CM.f _8ubtract_con8tant_2.lL 

(y , (f loat)CM_geometry_axis_length 
(CM. vp_8et .geometry (CM.current.vp.set) , 2) /2. 0,23, 8) ; 

CM.u.move. 1L  (z , *oz , 32) ; 
rotate.constant  (x,y,-(*rz)> ; 
rotate.constant  (y,z,*rx); 

CM.f _new8_8ub_always_3_ 1L  (gx , y , y , 1 , CM.upward ,23,8); 
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CM.f _nevs_sub_alvays_3_lL  (gy ,x,x, 1 .CM.upward, 23, 8) ; 

CM.f _news_sub_always_3_ 1L  (gz ,  x ,  x ,  1 , CM.upward ,23,8); 

CM.f _news_sub_mult_4_lL  (gx,z,z,gx, 2, CM.upward, 23, 8) ; 

CM_f _new8_8ub_mult_4.lL  (gy,z,z,gy, 2, CM.upward, 23, 8) ; 
CM_f_news_sub_mult_4_lL  (gz.y ,y ,gz, 2, CM.upward, 23, 8) ; 
CM_f_aew8_8ub_always_3.lL  (*dest ,z,z,l .CM.upward, 23, 8) ; 
CM_f_news_sub_mult_4_lL  (*dest ,y ,y ,*dest ,2, CM.upward, 23, 8) ; 
CM_f_8ubtract_2.lL  (gx,*dest,23,8) ; 

CM.f _new8_8ub_always_3_ 1L  (*dest ,z ,z , 1 .CM.upward ,23 , 8) ; 
CM_f_news_sub_mult_4_lL  (*dest,x,x,*dest, 2, CM.upward, 23, 8) ; 

CM.f _subtract_2.lL  (gy,*dest,23,8) ; 

CM.f _new8_8ub_always_3.lL  (*dest ,y ,y , 1, CM.upward, 23, 8) ; 

CM.f _new8.Bub_mult.4_ 1L  (*dest , x , x , *dest , 2 , CM.upward ,23,8); 

CM.f .subtract _2.1L  (gz,*dest,23,8) ; 

CM.f _negate_l.lL  (gy,23,8); 

/*  normal  of  cross  product*/ 

CM.f .multiply .3. 1L  (norm,gx,gx,23,8) ; 

CM_f_mult_add_lL  (norm,gy,gy .norm, 23, 8) ; 

CM.f _mult_add.lL  (norm,gz,gz,norm,23,8) ; 

/*  perform  dot*/ 

CM_f_8ub_const_mult.lL  (gx,x, 1000.0,gx,23,8) ; 

CM.f .sub.const .mult. 1L  (gy ,y, 1000.0, gy ,23,8) ; 

CM_f_8ub_const_mult.lL  (gz,z,-1000.0,gz,23,8) ; 

CM_f_add_3_lL  (*dest,gx,gy,23,8) ; 

CM.f _add_2. 1L  (*dest , gz . 23 , 8) ; 

/*  normal  of  light  vector  (can  be  combined)*/ 

CM.f _8ubtract_con8tant_3.lL  (gx,x, 1000.0,23,8) ; 
CM_f_8Ubtract_constant_3.lL  (gy,y, 1000.0,23,8) ; 

CM.f _8ubtract_constant_3.lL  (gz,z,-1000.0,23,8) ; 

CM.f .multiply _2_1L  (gx,gx,23,8) ; 

CM.f .mult _ add. 1L  (gx.gy.gy ,gx,23,8) ; 

CM_f_mult_add.lL  (gx,gz,gz,gx,23,8) ; 

CM.f .multiply .2. 1L  (norm, gx, 23, 8) ; 

CM.f _8qrt_l.lL  (norm, 23, 8); 

CM_f_divide_2_lL  (*dest,norm,23,8) ; 
smooth.f loat_image(*dest) ; 

8mooth_float_image(*dest) ; 
smooth_float_image(*dest) ; 
smooth_float_image(*dest) ; 

CM_8tore_context(gx) ; 

CM.f _lt_zero.lL  (*dest,23,8) ; 

CM.logand.context.with.testO ; 

CM.f _move_zero.lL  (*dest ,23 ,8) ; 

CM.load.context(gx) ; 

CM.f .mult iply_constant_3_ 1L  (norm, *dest , 255 . 0- (float ) AMBIENT ,23 , 8) ; 
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CM_u_f _trmicate_2_2L  (*dest,norm,8,23,8) ; 
CM_u_add_coiiStant_2_lL  (*dest .AMBIENT, 8)  ; 
CM_deallocate_stack_through  (gx) ; 
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BIO  Polynomial  Evaluation  Routines 


I 


INTEGER  FUNCTION  MAKE.HORNER.COEF (COEF. ARRAY ,  LENGTH) 

INTEGER  COEF. ARRAY,  LENGTH 

INCLUDE  '/usr/include/an/paris-configuration-fort.h’ 

INCLUDE  ’ /usr/include/cm/CMF_def s . h ’ 

INTEGER  TEMP.LUT 
INTEGER  RESULT 
INTEGER  MAKE.REAL .LOOKUP 

TEMP.LUT  *=  MAKE_REAL_LOOKUP( COEF. ARRAY,  LENGTH) 

CALL  _MAKE.HORNER.COEF (RESULT,  TEMP.LUT,  COEF.ARRAY ,  LENGTH) 
MAKE.HORNER.COEF  *  RESULT 

END  FUNCTION  MAKE.HORNER.COEF 


SUBROUTINE  EVAL_HORNER(RESULT ,  COEFS,  X) 

INTEGER  RESULT,  COEFS,  X 

INCLUDE  ’/usr/includa/cm/paris-conf iguration-fort .h’ 
INCLUDE  ’/usr/include/cm/CMF.dels.h’ 

integer  the.vp.set 

the.vp.set  ■  CMF_get_vp_set_id(x) 

call  CM.set.vp.set (the.vp.set) 

CALL  _EVAL_HORNER(CMF_GET_FIELD_ID(RESULT) ,  COEFS, 

♦  CMF.GET.FIELD.ID(X)) 

CALL  CMF.Bet.is.modif ied(result ,M0DIF) 

RETURN 

END 


SUBROUTINE  FREE.HORNER.COEF (COEFS) 
INTEGER  COEFS 

CALL  .FREE.HORNER.COEF (COEFS) 

RETT'N 

END 
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tinclude  <stdio.h> 
tinclude  <cm/paris.h> 
tinclude  ./lookup/lookup. h" 
tinclude  <cm/impctl .h> 

struct  horner.coef  {struct  lut  *  mylut;  int  size;}-; 

typedef  struct  horner.coef  horner.coef _t ; 

void  make.horner.coef 0 ; 
void  eval.hornerO ; 
void  free_horner_coef () ; 

tif  def ined(sparc) 

t  define  MAKE_HORNER_COEF  make.horner.coef _ 
t  define  EVAL_HORNER  eval.horner. 
t  define  FREE_HORNER_COEF  free.horner.coef _ 
t  define  FREE_L00KUP  free.lookup. 
tendif 

IMP.impid.t  coefs_imp; 
char  *malloc(); 

void  MAKE.HORNER.COEF (horner_lut ,  temp.lut,  coef .array,  length) 
horner.coef _t  **horner_luc ; 
lut_t  ♦♦temp.lut; 
float  ♦  coef .array; 
int  * length; 

{ 

tifndef  I LB 

coefs.imp  -  IMP.open.impO'f ast-poly .  imi"  ,  "CMISPOLYALWAYS" ,  NO.LOAD.IMPS); 
telse 

IMP. include. imp.library (ILBNAME) ; 

coefs.imp  =  IMP_open_imp(IMP_LIBRARIES,  "CMISPOLYALWAYS",  NO.LOAD.IMPS); 
tendif 

♦horner.lut  =  (horner.coef _t  *)  malloc(sizeof (horner.coef _t) ) ; 
(♦♦horner.lut) .mylut  =  ♦temp.lut; 

(♦♦horner.lut) . size  =  *length; 
if  (♦length  <  3) 

printf ("Error:  polynomial  must  have  at  least  3  coef icients\n") ; 

} 


void  eval.horner.internnl (result ,  coef a,  x,  size) 
CM.f ield.id.t  result,  coefs,  x; 
int  size; 

{ 
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unsigned  x.addr ,  result.addr,  coefs_addr; 
unsigned  x.loc,  x_inc,  result.loc,  result.inc,  coefs.loc; 
_CMI_decode_location_increment (result,  result.loc,  result.inc) ; 
_CMI_decode_location_increment(x,  x_loc,  x_inc) ; 

_CMI_decode_location(coefs,  coefs.loc) ; 

IMP_execute_imp_id(coef s_imp) ; 

IMP_aend_imp_data(size-2) ; 

IMP_send_imp_data(result_loc) ; 

IMP_send_imp_data(result_inc) ; 

IMP_8end_imp_data(x_loc) ; 

IMP_send_imp_data(x_inc) ; 

IMP_send_imp_data(coefs_loc) ; 

> 

void  EVAL_HOFNER(result ,  coefs,  x) 

CM_field_id_t  *result; 
horner_coef_t  ♦♦coefs; 

CM_f ield_id_t  *x; 

{ 

if  ( (♦♦coef s) .mylut->allocated_p) 

eval_horner_internal (♦result,  (**coefs) .mylut->cm_f ield,  *x,  (♦♦coef s) . size) 
else  { 

printf ("eval_horner :  coeficients  deallocated!  returning  0.\n"); 

♦result  *  0.0; 

> 

> 

void  FREE_H0RNER_C0EF (coefs) 
horner.coef _t  ♦♦coefs; 

{ 

FREE.L00KUP (♦coefs) ; 

> 
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Bll  Fast  Fourier  Transform  Routine 


subroutine  f ft (re.dest , im.dest , re.source , im.source , 

+  operation) 

c 
c 
c 
c 
c 
c 
c 

include  ’/usr/include/cm/paris-conf iguration-f ort .h’ 
include  * /usr / include/cm/ CMF.def s .  h  ’ 

integer  re.dest , im.dest , re.source , im.source , operation 
integer  re.dest.id , im.dest.id .re.source.id , im.source.id 
integer  vpset 

re.dest.id  ■  cmf .get.f ield.id(re.dest) 
im.dest.id  *  cmf .get.f ield.id(im.dest) 
re.source.id  *=  cmf .get.f ield.id(re.source) 
im.source.id  *  cmf .get.f ield_id( im.source) 


re.dest  :  single  precision  real  destination  field 

im.dest  :  single  precision  imaginary  destination  field 

re.source  :  single  precision  real  source  field 

im.source  :  single  precision  imaginary  source  field 

operation  :  0  no  operation 

1  forward  transform 

2  inverse  transform 


vpset  *  cmf _get_vp_set_id(re_dest) 

if  (.not.  (  (vpset  .eq.  cmf_get_vp_Bet.id(im_dest))  .and. 

+  (vpset  .eq.  cmf _get_vp_set_id(re_source) )  .and. 

+  (vpset  .eq.  cmf _get_vp_ set. id (im.source) ) ) )  then 

print*,’  ERROR  source  and  dest  are  not  in  the  same  vpset’ 
stop 
endif 

c  call  c  routine  which  makes  paris  call  to  fft 

call  _CFFT(vpset .re.dest.id, im.dest.id, re.source.id, 

+  im.source.id, operation) 

call  CMF.set.is.modif ied(re_dest ,M0DIF) 
call  CMF.set.is.modif ied(im_dest ,M0DIF) 
return 
end 

ftdefine  len  32 
#define  axesmax  31 
Vdefine  n  4 
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♦include  <cm/paris .h> 
♦include  <stdio.h> 


♦if  defined(sparc) 

♦  define  CFFT  cfft_ 

♦endif 

static  CM_geometry_id_t  fft.geoCn]; 
static  CMSSL_fft_setup_t  fft_init[n]; 
static  int  setup.ptr  =  0; 
static  int  deallocate  =  0; 

extern  CMSSL_fft_setup_t  CMSSL_c_fft_setupC) ; 


void  CFFT (vpset ,re_dest , im.dest ,re_ source , im_source , operation) 
CM_vp_set_id_t  *vpset; 

CM_f ield_id_t  *re_dest , *im_dest , *re_source , *im_source ; 
int  operation  □  ; 


{  CM_field_id_t  dest_complex_f ield,source_complex_f ield; 

int  ops  [axesmax] ,source_bit .order [axesmax] ,dest_bit_order [axesmax]  ; 
int  source_cm_order  [axesmax] ,dest_cm^order [axesmax] , scale [axesmax] ; 
int  rank , i , imag.part ; 

CM_geometry_id_t  geom.id; 
int  index; 

CM_set_vp_set(*vpset) ; 

CM.set.contextO  ; 

geom.id  *  CM_vp_set_geometry (*vpset) ; 
rank  «  CM_geometry_rank(geom_id) ; 

source_complex_f ield  =  CM_allocate_stack_f ield(2  *  len) ; 
dest_complex_f ield  *  CM_allocate_stack_f ield(2  *  len)  ; 
imag.part  «  CM_add_of fset_to_f ield_id(source_complex_f ield.len) ; 
CM_u_move_lL(source_complex_f ield, *re_80urce, len) ; 
CM_u_move_lL(imag_part ,*im_source,len) ; 

/*  set  up  defaults  for  call  to  paris  function  c-fftl 

cm  order: 


CMSSL.default  0 
CMSSL.send  1 
CMSSL.news  2 
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bit  order: 

CMSSL.normal  0 
CMSSL.bit.reversed  1 

scale: 

CMSSL.noscale  0 
CMSSL.scale.sqrt  1 
CMSSL.scale.n  2  */ 


for  (i=l;i<rank;i++) 

{if  (operation [i-l]  *=  0) 

{ops[i]  =  CMSSL_nop; 
source_bit_order[i]  *  CMSSL_normal; 
dest_bit_order  [i]  =  CMSSL.normal; 

>; 

if  (operation [i-l]  ==  1) 

{ops[i]  *  CMSSL.f _xf orm; 
source.bit_order[i]  *  CMSSL_normal ; 
dest_bit_order [i]  ■  CMSSL.bit.reversed; 

>; 

if  (operation [i-l]  «  2) 

{ops[i]  *  CMSSL.i.xform; 
source_bit_order[i]  «  CMSSL.bit.reversed; 
dest.bit.order [i]  *  CMSSL.normal ; 

>; 

source_cm_order  [i]  *  CMSSL.def ault. 124; 
de8t_cm_order [i]  =  CMSSL.def ault. 124; 
scale [i]  *  CMSSL.noscale ; 

> 

/*  no  operation  along  axis  0  */ 


ops [0]  *  CMSSL.nop ; 

source.cm.order [0]  ■  CMSSL.def ault_124; 
dest.cm.order [0]  *  CMSSL.def ault_124; 
scale[0]  *  CMSSL.noscale; 

/*  check  if  the  front  end  setup  descriptor  for  this  particular 
geometry  has  already  been  allocated  and  is  contained 
in  the  current  list  of  setup.id’s  (if  not  then  add  to  the  list). 


index  ■  -1; 
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for  (i=0;i<n  &&  index  ==  -l;i++) 

if  (geom.id  **  fft_geo[i])  index  «  i; 

if  (index  ==  -1) 

/*  add  to  list  and  deallocate  a  setup  if  out  of  room  */ 

{  if  (deallocate  ==  1) 

CMSSL_deallocate_setup(f ft.init [setup.ptr] ) ; 
fft.geo  [setup _ptr]  =  geom.id; 

/*  create  setup  descriptor  for  this  geometry  */ 

fft_init[setup_ptr]  *  CMSSL_c_fft_setup(geom_id) ; 

index  =  setup.ptr; 

setup_ptr++; 

/*  reset  setup.ptr  to  zero  if  end  of  list  is  reached  */ 
if  (setup.ptr  **  n) 

{ 

setup.ptr  **  0; 

deallocate  =  1; 

> 

>; 

/*  ****  paris  call  */ 

CHSSL.c.c.ff t (dest.complex.f ield , source.complex.f ield , 
fft.init [index] , ops .source.bit .order , 
dest .bit.order , source.cm.order , dest_cm_order , scale) ; 


/+  extract  real  and  imaginary  parts  +/ 

imag.part  *  CM.add.off set.to.f ield_id(dest_complex_f ield, len) ; 
CM.u.move. lL(*re_dest , dest.complex.f ield , len) ; 
CM_u_move_lL(*im_dest , imag.part , len) ; 

CM_deallocate_stack_through(source_complex_f ield) ; 

} 
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B12  Matrix  Multiply  Routine 


subroutine  matmull (x,y,z) 

c  parameters: 
c 

c  x  :  single  precision  real  array:  sourcel 

c  y  :  single  precision  real  array;  source2 

c  z  :  single  precision  real  array;  result  of  matrix  multiply 

c  of  x  and  y 

include  ’/usr/include/cm/paris-conf iguration-fort .h’ 
include  ’ /usr/include/cm/CMF_def 8 .h’ 

integer  x,x_id,x_geom,x_vpset 
integer  y ,y_id,y_geom,y_vpset 
integer  z,z_id,z_geom,z_vpset 
integer  a_geom,b_geom,c_geom 
integer  rank .descriptor. array (7 ,7) 
integer  i 

x_id  ■  cmf _get_f ield_id(x) 
y_id  *  cmf _get_field_id(y) 
z_id  «  cmf_get_f ield_id(z) 

x. vpset  *  cmf _get_vp_set_id(x) 

y. vpset  ■  cmf _get_vp_set_id(y) 

z. vpset  =  cmf _get_vp_set_id(z) 

if  (x_id  .eq.  0)  then 
print  *, 

+  ’ Error,  the  a  argument  to  matmull  is  not  on  the  CM* 
stop 
endif 

if  (y_id  .eq.  0)  then 
print  *, 

♦’ Error,  the  b  argument  to  matmull  is  not  on  the  CM’ 
stop 
endif 

if  (z_id  .eq.  0)  then 
print  *, 

+’ Error,  the  c  argument  to  matmull  is  not  on  the  CM’ 
stop 
endif 
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if  (cmf _get_axis_extent(x , 1)  .ne.  cmf_get_axis_extent(y ,0)  .or. 

+  cmf _get.axis.extent(z,0)  .ne.  cmf.get.axis_extent(x,0)  .or. 

+  cmf_get_axis_extent(z,l)  .ne.  cmf_get_axis_extent(y ,1))  then 

print* , 

♦’Error,  the  dimensions  axe  not  compatible’ 
stop 
endif 

x_geom  *  cm_vp_set_geometry(x_vp8et) 
rank  =  cm_geometry_rank(x_geom) 

do  i=l , rank-1 

descriptor_array ( 1 , i)  ■  CM_geometry_axis_length(x_geom,i) 
descriptor_airray(3,i)  *  CM_geometry_axis_ordering(x_geom,i) 
descriptor_array(4,i)  = 

+  CM.geometry_axis_on_chip.bits (x.geom , i) 

descriptor_array(6,i)  = 

+  CM.geometry.axis.of f .chip.bits (x.geom , i) 

enddo 

a_geom  *  cm_create_detailed_geometry(descriptor_array , rank-1) 
call  cm.set.vp.set.geometry (x.vpset , a_geom) 
if  (x.vpset  .ne.  y.vpset)  then 

y. geom  *  cm_vp_set_geometry(y_vpset) 
rank  =  cm_geometry_rank(y_geom) 

do  i*l, rank-1 

descriptor.array ( 1 , i)  *  CM_geometry_axis_length(y_geom,i) 
descriptor_array(3,i)  =  CM_geometry_axis_ordering(y_geom,i) 
descriptor_array(4,i)  = 

♦  CM_geometry_axis_on_chip_bits (y.geom , i) 
descriptor. array (6, i)  = 

♦  CM_geometry.axis.of f .chip.bits (y.geom, i) 
enddo 

b.geom  =  cm. create_detailed_geometry(descriptor_array, rank-1) 
call  cm.set.vp.set.geometry  (y.vpset .b.geom) 

endif 

if  (x.vpset  .ne.  z.vpset  .and.  y.vpset  .ne.  z.vpset)  then 

z. geom  *  cm_vp_set_geometry(z_vp8et) 
rank  *  cm.geometry.rank (z.geom) 

do  i=l, rank-1 
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descriptor_array(l,i)  a  CM_geometry_axi8_length(z_geom,i) 
descriptor_array(3,i)  a  CM_geometry_axis_ordering(z_geom, i) 
descriptor_array(4,i)  = 

+  CM_geometry_axis_on_chip_bits(z_geom,i) 

descriptor_array(6,i)  * 

♦  CM_geometry_axis_off .chip. bits  (z.geom, i) 

enddo 

c.geom  «  an_create_detailed_geometry(deBcriptor_array , rank-1) 
call  cm.set.vp.set.geometry (z.vpset , c.geom) 

endif 

call  cm_u_move_zero_ always. 11 (z_id , 32) 
call  anssl_8_matrix_multiply(x_id,y_id,z_id) 

call  cm.set.vp.set.geometry (x.vpset ,  x.geom) 
call  cm_deallocate_geometry(a_geom) 
if  (t.vpset  .ne.  y.vpset)  then 

call  cm.set.vp.set.geometry (y.vpset ,  y.geom) 
call  cm_deallocate_geometry (b_geom) 
endif 

if  (x.vpset  .ne.  z.vpset  .and.  y.vpset  .ne.  z.vpset)  then 
call  cm_set_vp_aet_geometry (z.vpset ,  z.geom) 
call  cm.deallocate.geometry (c.geom) 
endif 


return 


B13  Linear  System  Routines 


subroutine  gauss (ndim, mat) 

solve  ndim  by  ndim  system  of  linear  equations 
forcing  vector  is  augmented  (last  column  of  mat) 

parameters  :  ndim  -  input;  integer;  dimension  of  system 
mat  -  input;  real; 

ndim  by  ndim+1  system  of  linear 
equations  to  be  solved.  Forcing 
vector  is  augmented  (last  column) . 
output;  solution  vector  is  contained 
in  last  column 

integer  ndim.i 

real  mat(ndim, ndim+1) ,temp(ndim+l) 
logical  mask (ndim .ndim+1) 
logical  find_ index 

cmf$  layout  mat( :news, :news) ,temp(:nevs) ,mask( :nevs, :news) 

mask  *  .false. 

do  i=l .ndim 

c  re-select  grid  each  time  through 
mask  *  . true . 

c  select  maximum  column  element  from  rows  i,i+l . ndim 

c  for  pivotting  and  swap  rows 

c  ******  j  m  maxloc(abs (mat (i: ndim, i)))  +  (i-1) 

c  maxloc  is  not  working  in  current  release  0.5  of  compiler 

c  swap  rows 

c  temp  *  mat(i, : ) 

c  mat(i, :)  «  mat(j , :) 

c  mat(j , : )  «  temp 

c  divide  row  i  by  pivot 

mat(i,:)  =  mat(i, : )/mat(i,i) 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 
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c  current  row  i  is  left  unchanged  (masked  off) 
c  subtract  multiples  of  it  from  rows  i+1 ,i+2, . . . ,ndim 
c  to  zero  column  i 

mask(i,:)  =  .false, 
where  (mask) 

mat  =  mat  -  spread (mat (i , : ) , 1 ,ndim)  * 

+  spread(mat(: ,i) ,2,ndim+l) 

endwhere 
enddo 
return 
end 

subroutine  inv (ndim, mat) 
c  solve  for  inverse  of  ndim  by  ndim  system 

c 

c  parameters  :  ndim  -  input;  integer;  dimension  of  system 
c  mat  -  input;  real; 

c  ndim  by  ndim  system 

c  output;  inverse  of  system  returned 

c  overwrites  mat 

c 

integer  ndim.i 
real  mat (ndim, ndim) 
cmf$  layout  mat (: news, : news) 

real  mattemp (ndim, 2*ndim) ,temp(2*ndim) 
cmf$  layout  mattemp( :news , ;news) ,temp( :news) 
logical  mask (ndim, 2*ndim) 
cmf$  layout  mask( :news , :news) 
logical  find.index 

c  intialize  mattemp  rectangular  [mat  1 identity] 

mattemp  ■=  0.0 
do  i*l,ndim 

mattemp(i,ndim+i)  *  1.0 
enddo 

mattemp(l:ndim,l:ndim)  *=  mat ( 1 :ndim, 1 : ndim) 

mask  ■  .false, 
do  i*l,ndim 

c  re-select  grid  each  time  through 
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mask  =  .true. 


c  select  maximum  column  element  from  rows  i,i+l . ndim 

c  for  pivotting  and  swap  rows 

c  ******  j  =  maxloc(abs(mattemp(i:ndim,i)))  +  (i-1) 

c  swap  ~ows 

c  temp  =  mattempCi,:) 

c  mattempCi,:)  =  mattempC j , :) 

c  mattempC j,:)  =  temp 

c  divide  row  i  by  pivot 

mattempCi,:)  *  mattempCi, :)/mattempCi,i) 

c  current  row  i  is  left  unchanged  (masked  off) 
c  subtract  multiples  of  it  from  rows  i+l,i+2, . . . ,ndim 
c  to  zero  column  i 

maskCi,:)  *  .false, 
where  (mask) 

mattemp  *  mattemp  -  spread (mattempCi, :) , 1 ,ndim)  * 
♦  spread(mattemp( : ,i) ,2,2*ndim) 

endwhere 
enddo 

mat  =  mattempC : ,ndim+l:2*ndim) 

return 

end 
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B14  Tridiagonal  Solver  Routine 


c  interpretation  of  Michael  Mascagni’s  tridiagonal  solver 
c  originally  written  in  O 

c  n  can  most  likely  be  derived  from  dest. 

subroutine  tridiag(dest ,1 ,d,u,rhs) 
real  dest,l,d,u,rhs 
integer  off set, power 

integer  address , lp , dp , up , rhsp , lm , dm , um , rhsm , alpha .gamma 
integer  11 , Id , lu , lhs , temp , nn , array .context 
integer  entry_vp_set,i 

include  * /usr/include/cm/paris-conf iguration-f ort .h’ 
include  ’/usr/ include/cm/ CMF.defs .h’ 

entry.vp.set  *  cm_current_vp_set() 
call  cm.set.vp.set  (cmf _get_vp_set_id(l) ) 
cadi  cm_set_context() 
nn  ■  cmf .get. axis. extent (1 ,0)-l 

address  ■  cm_allocate_stack_f ield(32) 

11  *  cmf_get_field_id(l) 

Id  •=  cmf  .get  .field,  id  (d) 

lu  =  cmf .get.f ield.id(u) 

lrhs  ■  cmf .get.f ield.id(rhs) 

adpha  «  cmf .get.f ield.id  (dest) 

lp  =  cm.allocate.stack.f ield(32) 

dp  «  cm.allocate.stack.f ield  (32) 

up  *  cm.allocate.stack.f ield(32) 

rhsp  *  cm.allocate.stack.f ield (32) 

lm  ■  cm.allocate.stack.f ield  (32) 

dm  ■  cm.allocate.stack.f ield  (32) 

um  =  cm_adlocate_8tack_f ield  (3J) 

rhsm  *  cm.allocate.stack.f ield  (32) 

gamma  *  cm.allocate.stack.f ield  (32) 

temp  *  cm.allocate.stack.f ield  (1) 

array.context  ■  cm.allocate.stack.f ield(l) 

call  cm_my_news_coordinate.il  (address, 0,32) 
call  cm_u_eq_constant.il (address ,0,32) 
call  cm_logand_context_with_test() 
do  2  i*l ,cmf .get.rank(l) 

call  cm_my_news_coordinate.il  (address, i, 32) 

call  cm_u_lt_constant_ll(address,cmf_get_axis_extent(l,i-l) ,32) 
call  cm.logand.context.with.testO 
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2  continue 

call  cm.store.context  (array.context) 
call  cm_my_news_coordinate.iL  (addrer  *  * ,32) 
offset  =1 
power  *0 

1  call  cm. load. context  (array.context) 

call  cm_u_le_ constant. 11  (address , (un- off set) ,32) 
call  cm_store_test  (temp) 
call  cm_load_context(temp) 

call  cm_get_from_power_two_ll(lp,ll, 1 .power ,cm_upward,32) 
call  cm.get.from.power _two_ 11 (dp , Id , 1 ,powe: - , cm.upward ,32) 
call  cm.get.f rom.power . two. 11 (up , lu , 1 , power , cm.upward , 32? 
call  cm.get.f rom.power.two_ 11 (rhsp ,  lrhs , 1 .power .cm.upward 
!  ,32) 

call  cm_f_multiply_constant_3.il  (gamma, lu,dble(-l . 0) ,23 ,8) 
call  cm_f_divide_2.il  (gamma, dp, 23, 8) 
call  cm.load. context (array .context) 
call  cm_logxor.constant_2.il  (temp, 1,1) 
call  cm.logand.context(temp) 

call  cm_f_move_constant.il  (lp.dble(O.O) ,23,8) 
call  cm_f_move_constant.il  (dp,dbie(l .0) ,23,8) 
call  cm_f_move_constant.il  (up.dble(O.O) ,23,8) 
call  cm.f _move_con8tant.il  (rhsp, dble(u.O) ,23,8) 
call  cm_f_move_constant.il  (gamma, dble(O.O) ,23,8) 
call  cm_load_context  (array.context) 
call  cm_u_ge_constant.il  (address, of /set, 32) 
call  cm.store.test  (temp) 
call  cm_logand_context_with_te8t() 

call  cm.get.f rom.power.two. 11 (lm , 11 , 1 , power , cm.downwai d , 

!  32) 

call  cm_get_from_power_two_ll(dm,ld, 1 .power ,cm_downward, 

!  32) 

call  cm.get.f rom.power.two. 11 (urn , lu , 1 , power , rm_ downward , 

!  32) 

call  cm_get_from_power_two.il (rfcsm , lrhs , 1 , power , 

!  cm. downward, 32) 

call  cm_f_multiply_constant_3.il  (alpha, 11, dble(-l.O) ,23,8) 

call  cm_f_divide_2.il  (alpha, dm, 23 ,8) 

call  cm.load.context (array.context) 

call  cm_logxor_con8tant_2.il  (temp, 1,1) 

call  cm.logand.context(temp) 

call  cm_f_move_constant.il  (lm,dble(0.0) ,23,8) 

call  cm.f _move_con8tant.il  (dm.dble(l.O) ,23,8) 

call  cm.f _move_constant.il  (urn, dble(O.O) ,23,8) 

call  cm.f _move_con8tant.il  (rhsm,dble(0.0) ,23,8) 

call  cm_f_move_constant.il  (alpha,dble(0.0) ,23,8) 

call  cm.load. context (array.context) 

call  cm_f_multiply_3.il  (11, alpha, lm, 23, 8) 
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call  cm_f _multiply_3_ll  (lu, gamma, up, 23, 8) 
call  cm_f _mult_add_ll  (Id, alpha, urn, Id, 23, 8) 
call  cm_f _mult_add_ll  (Id, gamma, lp, Id, 23, 8) 
call  cm_f_mult_add_ll  (lrhs .alpha, rhsm.lrhs ,23,8) 
call  cm_f _mult_add_ll  (lrhs, gamma, rhsp, lrhs, 23, 8) 
call  cm_f _divide_3_ll  (alpha, lrhs, Id, 23, 8) 
power  *  power* 1 
offset  =  off set+off set 
if  (offset  .le.  nn)  then 
goto  1 
endif 

call  cm_deallocate_stack_through  (address) 

call  cm_set_vp_set  (entry_vp_set) 

call  CMF_set_is_modified(dest,MODlF) 

return 

end 
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